AHIPAS03        ;NC/RLP De-Enroll Patients from Clinic               11-Dec-01
        ;;v1.0
        ;
EN      S STDTDIS=3011218               ; set enrollment date of discharge
        S STDISRSN="Per MAS 18-Dec-01"  ; set enrollment reason for discharge
        S STSTATUS="I"                  ; set enrollment current status
        S STOK=0                        ; 0 - nothing set, 1 - node updated
        ;
L1      S DFN=0 F  S DFN=$O(^DPT(DFN)) Q:'DFN  D  ;
        . S DE=0 F  S DE=$O(^DPT(DFN,"DE",DE)) Q:'DE  D  ;
        . . S CLNCNUM=+$P(^DPT(DFN,"DE",DE,0),"^",1)
        . . S CLNCSTA=$P(^DPT(DFN,"DE",DE,0),"^",2)
        . . ;
        . . ; screen clinics - do NOT de-enroll if clinic is in the list
SCN     . . I $$CLN(CLNCNUM),CLNCSTA']"" D  ;
        . . . S ENRLIEN=0 F  S ENRLIEN=$O(^DPT(DFN,"DE",DE,1,ENRLIEN)) Q:'ENRLIE
N  D  ;
        . . . . S ENRLDTE=$P(^DPT(DFN,"DE",DE,1,ENRLIEN,0),"^",1)
        . . . . S ENRLDIS=$P(^DPT(DFN,"DE",DE,1,ENRLIEN,0),"^",3)
        . . . . I ENRLDIS']"" D DISPLAY I STOK D  ;
        . . . . . S $P(^DPT(DFN,"DE",DE,0),"^",2)="I"
        . . . . . S $P(^DPT(DFN,"DE",DE,1,ENRLIEN,0),"^",3)=STDTDIS
        . . . . . S $P(^DPT(DFN,"DE",DE,1,ENRLIEN,0),"^",4)=STDISRSN
        Q
        ;
CLN(CLINIC)     S OK=1 D  ;
        . I CLINIC=2054 S OK=0 Q  ; EVANSTON - CORTEZ-LAPERA
        . I CLINIC=2763 S OK=0 Q  ; EVANSTON - MITCHELL, SATURDAY
        . I CLINIC=2784 S OK=0 Q  ; EVANSTON - MITCHELL,ANTHONY NP
        . I CLINIC=1748 S OK=0 Q  ; GURNEE - MALIEKEL,MD
        . I CLINIC=1749 S OK=0 Q  ; GURNEE - WILSON, PA-C
MC      . I CLINIC=2798 S OK=0 Q  ; MCHENRY - DR. N. BELO
        . I CLINIC=2799 S OK=0 Q  ; MCHENRY - DR. P. KOH (M/W/F)
        . I CLINIC=2728 S OK=0 Q  ; MCHENRY - MALANFANT,L (TU/THU)
MH      . I CLINIC=1156 S OK=0 Q  ; MENTAL HEALTH - ATUL
        . I CLINIC=991 S OK=0 Q  ; MENTAL HEALTH - CHEON IND
        . I CLINIC=1640 S OK=0 Q  ; MENTAL HEALTH - GALANG,R IND
        . I CLINIC=767 S OK=0 Q  ; MENTAL HEALTH - GARFIELD PTSD
        . I CLINIC=2579 S OK=0 Q  ; MENTAL HEALTH - GARFIELD, INT
        . I CLINIC=2717 S OK=0 Q  ; MENTAL HEALTH - GARFIELD, TUE
        . I CLINIC=1643 S OK=0 Q  ; MENTAL HEALTH - LEWIS,K IND
        . I CLINIC=1585 S OK=0 Q  ; MENTAL HEALTH - MOSS INTAKE
        . I CLINIC=1683 S OK=0 Q  ; MENTAL HEALTH - MOSS,L IND
        . I CLINIC=2382 S OK=0 Q  ; MENTAL HEALTH - MOSS,RED TEAM
        . I CLINIC=1647 S OK=0 Q  ; MENTAL HEALTH - PARHAD,H IND
        . I CLINIC=1800 S OK=0 Q  ; MENTAL HEALTH - PARHAD,H PREP
        . I CLINIC=1646 S OK=0 Q  ; MENTAL HEALTH - PARHAD,S IND
        . I CLINIC=2849 S OK=0 Q  ; MENTAL HEALTH - ROTH IND
        . I CLINIC=2592 S OK=0 Q  ; MENTAL HEALTH - VAI,WOMEN'S CL
        . I CLINIC=2383 S OK=0 Q  ; MENTAL HEALTH - VAID/RED TEAM
        . I CLINIC=2721 S OK=0 Q  ; MENTAL HEALTH - VAIDYA, MON
        . I CLINIC=2507 S OK=0 Q  ; MH GARFIELD - BLUE TEAM
        . I CLINIC=2719 S OK=0 Q  ; MH ICM - KANNEGANTI,M/MED CTR
        . I CLINIC=2558 S OK=0 Q  ; MH ICM - MOSS/CRC IND
        . I CLINIC=2814 S OK=0 Q  ; MH ICM - MOSS/IND DAY
        . I CLINIC=2816 S OK=0 Q  ; MH ICM - MOSS/IND EVENING
PC      . I CLINIC=2788 S OK=0 Q  ; PC - AVRAMIDIS,JOHN, M.D. F/U
        . I CLINIC=2869 S OK=0 Q  ; PC - AVRAMIDIS,JOHN, M.D. NEW
        . I CLINIC=2903 S OK=0 Q  ; PC - CHENG - NEW# ONLY
        . I CLINIC=2695 S OK=0 Q  ; PC - ELLIS, JAMES, PA-C
        . I CLINIC=2870 S OK=0 Q  ; PC - LABONNE - FOLLOW UP
        . I CLINIC=2783 S OK=0 Q  ; PC - LABONNE - NEW
        . I CLINIC=2693 S OK=0 Q  ; PC - LIPSON, BRIAN, M.D.
        . I CLINIC=2696 S OK=0 Q  ; PC - NG, HC., M.D.
        . I CLINIC=2754 S OK=0 Q  ; PC -PERURI,A
        . I CLINIC=2698 S OK=0 Q  ; PC - PINTO,JACK, M.D.
        . I CLINIC=2691 S OK=0 Q  ; PC - SAFROM
        . I CLINIC=2699 S OK=0 Q  ; PC - STEEPLETON, STEPHEN, PA-C
        . I CLINIC=2770 S OK=0 Q  ; PC - SYKES,P RNNP
        . I CLINIC=2927 S OK=0 Q  ; PC - WILSON, J.
        . I CLINIC=1326 S OK=0 Q  ; PC1 - CHENG,JEN
        . I CLINIC=1503 S OK=0 Q  ; PC2 - XANTHOPOULOS,JOH
        . I CLINIC=1450 S OK=0 Q  ; PC3 - LALITHA,P
        . I CLINIC=2701 S OK=0 Q  ; PC3 - ZEVELEVA, E
        . I CLINIC=1622 S OK=0 Q  ; PC5 - KHAYR,INF DIS
        . I CLINIC=1851 S OK=0 Q  ; PC5 - WOMEN'S HEALTH - SAFRON
        . I CLINIC=1852 S OK=0 Q  ; PC5 - WOMEN'S HEALTH GILDEN
        . I CLINIC=2305 S OK=0 Q  ; PC5 - WOMEN'S HEALTH KEPIC
SW      . I CLINIC=493 S OK=0 Q  ; SOCIAL WORK - CHRISTENSEN
        . I CLINIC=2856 S OK=0 Q  ; SOCIAL WORK - PC CARLSON
        . I CLINIC=2866 S OK=0 Q  ; SOCIAL WORK - PC CROSS
        . I CLINIC=2532 S OK=0 Q  ; SOCIAL WORK - PC GRACE
        . I CLINIC=2855 S OK=0 Q  ; SOCIAL WORK - PC POLESKI
        . I CLINIC=1834 S OK=0 Q  ; SOCIAL WORK = PC REGAN
        . I CLINIC=2531 S OK=0 Q  ; SOCIAL WORK - PC SENTENEY
        . I CLINIC=1351 S OK=0 Q  ; SOCIAL WORK - PC SPILLNER
        Q OK
        ;
DISPLAY ;
        W !,OK_":"_CLNCNUM_":"_DFN_":"_DE
        Q
        ;
        ;
        ; Verify that a Date of Discharge is entered for Enrollment Clinics
        ; that have a status of 'I' (inactive).  If incomplete, enter a
        ; a Date of Discharge and Reason for Discharge.
        ;
EN1     S STDTDIS=3011218
        S STDISRSN="Setting Date and Reason for Discharge"
        S STOK=0
        ;
L2      S DFN=0 F  S DFN=$O(^DPT(DFN)) Q:'DFN  D  ;
        . S DE=0 F  S DE=$O(^DPT(DFN,"DE",DE)) Q:'DE  D  ;
        . . S CLNCNUM=+$P(^DPT(DFN,"DE",DE,0),"^",1)
        . . S CLNCSTA=$P(^DPT(DFN,"DE",DE,0),"^",2)
        . . S OK=1
        . . S ENRLIEN=0 F  S ENRLIEN=$O(^DPT(DFN,"DE",DE,1,ENRLIEN)) Q:'ENRLIEN
 D  ;
        . . . S ENRLDIS=$P(^DPT(DFN,"DE",DE,1,ENRLIEN,0),"^",3)
        . . . I CLNCSTA]"",ENRLDIS']"" D DISPLAY I STOK D  ;
        . . . . S $P(^DPT(DFN,"DE",DE,1,ENRLIEN,0),"^",3)=STDTDIS
        . . . . S $P(^DPT(DFN,"DE",DE,1,ENRLIEN,0),"^",4)=STDISRSN
        Q