ACDFUL2.m

ACDFUL2 ;IHS/ADC/EDE/KML - IHS-SMBD/MLQ FU EXTRACT; 

 ;;4.1;CHEMICAL DEPENDENCY MIS;**1**;MAY 11, 1998

INIT ;

 S ACDHREC=""

 D GETDFN1 G:ACDHREC="" NOFUD

 D KILLVAR

 Q

GETDFN1 ;

 S ACDA=ACD6MO,ACDFLG="6" F ACDIX=0:0 S ACDA=$O(^ACDVIS("B",ACDA)) Q:ACDA=""!(ACDA>ACD6MOE)  D GETDFN2

 S ACDA=ACD12MO,ACDFLG="12" F ACDIX=0:0 S ACDA=$O(^ACDVIS("B",ACDA)) Q:ACDA=""!(ACDA>ACD12MOE)  D GETDFN2

 S ACDA=ACD18MO,ACDFLG="18" F ACDIX=0:0 S ACDA=$O(^ACDVIS("B",ACDA)) Q:ACDA=""!(ACDA>ACD18MOE)  D GETDFN2

 S ACDA=ACD24MO,ACDFLG="24" F ACDIX=0:0 S ACDA=$O(^ACDVIS("B",ACDA)) Q:ACDA=""!(ACDA>ACD24MOE)  D GETDFN2

 Q

GETDFN2 S ACDB=0 F ACDIX=0:0 S ACDB=$O(^ACDVIS("B",ACDA,ACDB)) Q:'+ACDB  D GETDFN3

 Q

GETDFN3 S ACDHREC=^ACDVIS(ACDB,0)

 S ACDT=$P(ACDHREC,"^",4)

 Q:$P(ACDHREC,"^",4)'="TD"

 ;D CHKTDC ; Q:T/D/C IS MOVED OR DIED

 S ACDPDFN=$P(ACDHREC,U,5)

 Q:$O(^ACDTDC("ALT",ACDPDFN,"A"),-1)>ACDA  ; quit if later TD

 Q:$$DOD^AUPNPAT(ACDPDFN)]""  ;       quit if patient deceased

 ; Start of patch, IHS/ASDST/JGH ACD*4.1*1 12/18/1998

 ; S ACDPRG=$P(^ACDVIS(ACDB,"BWP"),U) Q:ACDPRG'=DUZ(2) S ACDPRG=$P(^DIC(4,ACDPRG,0),U)

 S ACDPRG=$P(^ACDVIS(ACDB,"BWP"),U)  ; IHS/ASDST/JGH 12/18/1998

 ; The following line allows follow up due to view only local case.

 Q:ACDPRG'=DUZ(2)  ; IHS/ASDST/JGH ACD*4.1*1 12/18/1998

 S ACDPRG=$P(^DIC(4,ACDPRG,0),U)  ; IHS/ASDST/JGH 12/18/1998

 ; End of patch, IHS/ASDST/JGH ACD*4.1*1 12/18/1998 

 S ACDDT=$P(ACDHREC,U) S ACDDOS=$E(ACDDT,4,5)_"/"_$E(ACDDT,6,7)_"/"_$E(ACDDT,2,3) K ACDDT

 S ACDCMP=$P(ACDHREC,U,2),ACDCMP=$P(^ACDCOMP(ACDCMP,0),U,2)

 S ACDCMP2=$P(ACDHREC,U,7),ACDCMP=ACDCMP_ACDCMP2 K ACDCMP2

 ;S ACDPRV=$P(ACDHREC,U,3) S:ACDPRV ACDPRV=$P($G(^DIC(16,ACDPRV,0)),U)

 S ACDPRV=$P(ACDHREC,U,3) S:ACDPRV ACDPRV=$P($G(^VA(200,ACDPRV,0)),U)

 S ACDCID=$P(^AUPNPAT(ACDPDFN,0),U,6)

 S ACDNAME=$P(^DPT(ACDPDFN,0),U)

 S ACDDT=$P(^DPT(ACDPDFN,0),U,3) S ACDDOB=$E(ACDDT,4,5)_"/"_$E(ACDDT,6,7)_"/"_$E(ACDDT,2,3) K ACDDT

 K ACDPDD

 S DIC=9000001,DR="1602.2:1606.2",DA=ACDPDFN,DIQ="ACDPDD(" D DIQ1^ACDFMC

 S DIC="^ACDWORK(",DIC(0)="L",X=ACDNAME

 S DIC("DR")="1////"_ACDPRG_";2////"_ACDCMP_";3////"_ACDDOS_";4////"_ACDPRV_";5////"_ACDCID_";6////"_ACDDOB_";7////"_ACDFLG

 S DIC("DR")=DIC("DR")_";1101////"_ACDPDD(9000001,ACDPDFN,1602.2)_";1102////"_ACDPDD(9000001,ACDPDFN,1603.2)_";1103////"_ACDPDD(9000001,ACDPDFN,1604.2)_";1104////"_ACDPDD(9000001,ACDPDFN,1605.2)_";1105////"_ACDPDD(9000001,ACDPDFN,1606.2)

 K ACDPDD

 D FILE^ACDFMC

 K ACDHLD,ACDC

 Q

KILLVAR K ACDA,ACDB,ACDBEGDT,ACDC,ACDCID,ACDCMP

 K ACDDOB,ACDDOS,ACDFLG,ACDHREC,ACDIX,ACDNAME

 K ACDPDFN,ACDPRG,ACDPRV,ACDT,X,Y

 K ACD12MO,ACD12MOE,ACD18MO,ACD18MOE,ACD6MO,ACD6MOE,ACD24MO,ACD24MOE

 Q

NOFUD W !!,"No Follow Ups Appointments are Due for this month."

 D PAUSE^ACDDEU

 D KILLVAR

 Q

ACDFUL2   ;IHS/ADC/EDE/KML - IHS-SMBD/MLQ FU EXTRACT; 

 +1       ;;4.1;CHEMICAL DEPENDENCY MIS;**1**;MAY 11, 1998

INIT      ;

 +1        SET ACDHREC=""

 +2        DO GETDFN1

           IF ACDHREC=""

               GOTO NOFUD

 +3        DO KILLVAR

 +4        QUIT 

GETDFN1   ;

 +1        SET ACDA=ACD6MO

           SET ACDFLG="6"

           FOR ACDIX=0:0

               SET ACDA=$ORDER(^ACDVIS("B",ACDA))

               IF ACDA=""!(ACDA>ACD6MOE)

                   QUIT 

               DO GETDFN2

 +2        SET ACDA=ACD12MO

           SET ACDFLG="12"

           FOR ACDIX=0:0

               SET ACDA=$ORDER(^ACDVIS("B",ACDA))

               IF ACDA=""!(ACDA>ACD12MOE)

                   QUIT 

               DO GETDFN2

 +3        SET ACDA=ACD18MO

           SET ACDFLG="18"

           FOR ACDIX=0:0

               SET ACDA=$ORDER(^ACDVIS("B",ACDA))

               IF ACDA=""!(ACDA>ACD18MOE)

                   QUIT 

               DO GETDFN2

 +4        SET ACDA=ACD24MO

           SET ACDFLG="24"

           FOR ACDIX=0:0

               SET ACDA=$ORDER(^ACDVIS("B",ACDA))

               IF ACDA=""!(ACDA>ACD24MOE)

                   QUIT 

               DO GETDFN2

 +5        QUIT 

GETDFN2    SET ACDB=0

           FOR ACDIX=0:0

               SET ACDB=$ORDER(^ACDVIS("B",ACDA,ACDB))

               IF '+ACDB

                   QUIT 

               DO GETDFN3

 +1        QUIT 

GETDFN3    SET ACDHREC=^ACDVIS(ACDB,0)

 +1        SET ACDT=$PIECE(ACDHREC,"^",4)

 +2        IF $PIECE(ACDHREC,"^",4)'="TD"

               QUIT 

 +3       ;D CHKTDC ; Q:T/D/C IS MOVED OR DIED

 +4        SET ACDPDFN=$PIECE(ACDHREC,U,5)

 +5       ; quit if later TD

           IF $ORDER(^ACDTDC("ALT",ACDPDFN,"A"),-1)>ACDA

               QUIT 

 +6       ;       quit if patient deceased

           IF $$DOD^AUPNPAT(ACDPDFN)]""

               QUIT 

 +7       ; Start of patch, IHS/ASDST/JGH ACD*4.1*1 12/18/1998

 +8       ; S ACDPRG=$P(^ACDVIS(ACDB,"BWP"),U) Q:ACDPRG'=DUZ(2) S ACDPRG=$P(^DIC(4,ACDPRG,0),U)

 +9       ; IHS/ASDST/JGH 12/18/1998

           SET ACDPRG=$PIECE(^ACDVIS(ACDB,"BWP"),U)

 +10      ; The following line allows follow up due to view only local case.

 +11      ; IHS/ASDST/JGH ACD*4.1*1 12/18/1998

           IF ACDPRG'=DUZ(2)

               QUIT 

 +12      ; IHS/ASDST/JGH 12/18/1998

           SET ACDPRG=$PIECE(^DIC(4,ACDPRG,0),U)

 +13      ; End of patch, IHS/ASDST/JGH ACD*4.1*1 12/18/1998 

 +14       SET ACDDT=$PIECE(ACDHREC,U)

           SET ACDDOS=$EXTRACT(ACDDT,4,5)_"/"_$EXTRACT(ACDDT,6,7)_"/"_$EXTRACT(ACDDT,2,3)

           KILL ACDDT

 +15       SET ACDCMP=$PIECE(ACDHREC,U,2)

           SET ACDCMP=$PIECE(^ACDCOMP(ACDCMP,0),U,2)

 +16       SET ACDCMP2=$PIECE(ACDHREC,U,7)

           SET ACDCMP=ACDCMP_ACDCMP2

           KILL ACDCMP2

 +17      ;S ACDPRV=$P(ACDHREC,U,3) S:ACDPRV ACDPRV=$P($G(^DIC(16,ACDPRV,0)),U)

 +18       SET ACDPRV=$PIECE(ACDHREC,U,3)

           IF ACDPRV

               SET ACDPRV=$PIECE($GET(^VA(200,ACDPRV,0)),U)

 +19       SET ACDCID=$PIECE(^AUPNPAT(ACDPDFN,0),U,6)

 +20       SET ACDNAME=$PIECE(^DPT(ACDPDFN,0),U)

 +21       SET ACDDT=$PIECE(^DPT(ACDPDFN,0),U,3)

           SET ACDDOB=$EXTRACT(ACDDT,4,5)_"/"_$EXTRACT(ACDDT,6,7)_"/"_$EXTRACT(ACDDT,2,3)

           KILL ACDDT

 +22       KILL ACDPDD

 +23       SET DIC=9000001

           SET DR="1602.2:1606.2"

           SET DA=ACDPDFN

           SET DIQ="ACDPDD("

           DO DIQ1^ACDFMC

 +24       SET DIC="^ACDWORK("

           SET DIC(0)="L"

           SET X=ACDNAME

 +25       SET DIC("DR")="1////"_ACDPRG_";2////"_ACDCMP_";3////"_ACDDOS_";4////"_ACDPRV_";5////"_ACDCID_";6////"_ACDDOB_";7////"_ACDFLG

 +26       SET DIC("DR")=DIC("DR")_";1101////"_ACDPDD(9000001,ACDPDFN,1602.2)_";1102////"_ACDPDD(9000001,ACDPDFN,1603.2)_";1103////"_ACDPDD(9000001,ACDPDFN,1604.2)_";1104////"_ACDPDD(9000001,ACDPDFN,1605.2)_";1105////"_ACDPDD(9000001,ACDPDFN,1606.2)

 +27       KILL ACDPDD

 +28       DO FILE^ACDFMC

 +29       KILL ACDHLD,ACDC

 +30       QUIT 

KILLVAR    KILL ACDA,ACDB,ACDBEGDT,ACDC,ACDCID,ACDCMP

 +1        KILL ACDDOB,ACDDOS,ACDFLG,ACDHREC,ACDIX,ACDNAME

 +2        KILL ACDPDFN,ACDPRG,ACDPRV,ACDT,X,Y

 +3        KILL ACD12MO,ACD12MOE,ACD18MO,ACD18MOE,ACD6MO,ACD6MOE,ACD24MO,ACD24MOE

 +4        QUIT 

NOFUD      WRITE !!,"No Follow Ups Appointments are Due for this month."

 +1        DO PAUSE^ACDDEU

 +2        DO KILLVAR

 +3        QUIT