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
