ACDWDRV5 ;IHS/ADC/EDE/KML - DRV 5 REPORTS TAKEN FROM ACDPD GLOBAL;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
;//[ACDR7MENU]
F K ACDQUIT D DIR I $D(ACDQUIT) D PRHDR^ACD G ^ACDWK
DIR ;Menu
S ACDWDRV(5)=5
D PRHDR^ACD
;S:'$D(ACD27) $P(ACD27,"*",27)="*"
;W !!,ACD27,!,"* CDMIS PREVENTION REPORTS *",!,ACD27,!
F I=300:1:310 W !,I," ",$P($T(@I),";",3) I I=310 S DIR(0)="L^300:310^S ACDRPTS=Y",DIR("A")="RUN REPORT # " W ! D ^DIR S:X["^"!($D(DTOUT)) ACDQUIT=1 Q:$D(ACDQUIT)
I $D(ACDQUIT) K ACDWDRV Q
D ^ACDWRQ I $D(ACDQUIT) K ACDQUIT Q
D ^ACDWQ ; call to XBDBQUE
Q
;
L ;EP - FOR TASKMAN
S ACDNW(1)=ACDTO,ACDNW(2)=ACDFR,ACDNW(3)=ACDLOC,ACDNW(4)=ACDRPTS
S ACDTO=ACDNW(1),ACDFR=ACDNW(2),ACDLOC=ACDNW(3)
D ACDV
Q
;
S ACDDA=ACDDO D ^ACDWPD I ACDOK F ACDA1=0:0 S ACDA1=$O(^ACDPD(ACDDO,1,ACDA1)) Q:'ACDA1 D M^ACDWPD,@ACDTG
ACDV ;
K ^TMP("ACD",ACDJOB,ACDBT)
F ACD=ACDFR-.001:0 S ACD=$O(^ACDPD("B",ACD)) Q:'ACD!(ACD>ACDTO) D
. S ACDV=0
. F S ACDV=$O(^ACDPD("B",ACD,ACDV)) Q:'ACDV S ^TMP("ACD",ACDJOB,ACDBT,"HIT",ACDV)=""
. Q
Q
;
P ;EP - PRINT REPORT
K DIRUT
S ACDNW(1)=ACDTO,ACDNW(2)=ACDFR,ACDNW(3)=ACDLOC,ACDNW(4)=ACDRPTS
F ACDNW(0)=1:1:$L(ACDNW(4),",")-1 S ACDTO=ACDNW(1),ACDFR=ACDNW(2),ACDLOC=ACDNW(3),(ACDTG,ACDTGSUB)=$P(ACDNW(4),",",ACDNW(0)) D P2 Q:$D(DIRUT)
Q
;
P2 ;
S ACDV=0
F S ACDV=$O(^TMP("ACD",ACDJOB,ACDBT,"HIT",ACDV)) Q:'ACDV D Q:$D(DIRUT)
. S ACDDA=ACDV
. D ^ACDWPD
. Q:'ACDOK
. S ACDA1=0
. F S ACDA1=$O(^ACDPD(ACDV,1,ACDA1)) Q:'ACDA1 S ACDDO=ACDV D M^ACDWPD,@ACDTG
. Q
D HED
Q
;
HED ;Header vars
S ACDH(0)=$P($T(@ACDTG),";",3)_U_ACDLOC,ACDWDRV(5)=5 D HV^ACDWUTL
U IO D H S ACDTG="G"_ACDTG D @ACDTG Q
H ;EP
W @IOF,!,"CDMIS PREVENTION REPORT # "_$S(ACDTG:ACDTG,1:$E(ACDTG,2,6)),!,$P(ACDH(0),U) S ACDH(3)=ACDH(3)+1 W ?68,"PG ",ACDH(3),!,ACDH(50),$P(ACDH(0),U,2) D ASF^ACDWUTL W !,"DATA CAPTURED FOR: ",ACDH(2),!,ACDH(4),!
Q
300 ;;COMPONENT/ACTIVITY/LOCATION
S:'$D(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDCOMCL_"/"_ACDCOMT,ACDPRVA,ACDLOTY)) ^(ACDLOTY)="" S ^(ACDLOTY)=^(ACDLOTY)+1 Q
301 ;;COMPONENT/ACTIVITY/NUM SERVED
S:'$D(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDCOMCL_"/"_ACDCOMT,ACDPRVA)) ^(ACDPRVA)="" S ACDN0=^(ACDPRVA),$P(ACDN0,U)=$P(ACDN0,U)+1,$P(ACDN0,U,2)=$P(ACDN0,U,2)+ACDNUMR,^(ACDPRVA)=ACDN0 Q
302 ;;ACTIVITY/TARGET/NUMBER SERVED
S:'$D(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDPRVA,ACDTRG)) ^(ACDTRG)="" S ACDN0=^(ACDTRG),$P(ACDN0,U)=$P(ACDN0,U)+1,$P(ACDN0,U,2)=$P(ACDN0,U,2)+ACDNUMR,^(ACDTRG)=ACDN0 Q
303 ;;ACTIVITY/TARGET/LOCATION
S:'$D(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDPRVA,ACDTRG,ACDLOTY)) ^(ACDLOTY)="" S ^(ACDLOTY)=^(ACDLOTY)+1 Q
304 ;;ACTIVITY/TARGET/OUTCOME
S:'$D(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDPRVA,ACDTRG,ACDOUTC)) ^(ACDOUTC)="" S ^(ACDOUTC)=^(ACDOUTC)+1 Q
305 ;;ACTIVITY/TARGET
S:'$D(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDPRVA,ACDTRG)) ^(ACDTRG)="" S ^(ACDTRG)=^(ACDTRG)+1 Q
306 ;;ACTIVITY/OUTCOME
S:'$D(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDPRVA,ACDOUTC)) ^(ACDOUTC)="" S ^(ACDOUTC)=^(ACDOUTC)+1 Q
307 ;;ACTIVITY/LOCATION
S:'$D(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDPRVA,ACDLOTY)) ^(ACDLOTY)="" S ^(ACDLOTY)=^(ACDLOTY)+1 Q
308 ;;ACTIVITY/#SERVED
S:'$D(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDPRVA)) ^(ACDPRVA)="" S ACDN0=^(ACDPRVA),$P(ACDN0,U)=$P(ACDN0,U)+1,$P(ACDN0,U,2)=$P(ACDN0,U,2)+ACDNUMR,^(ACDPRVA)=ACDN0 Q
Q
309 ;;ACTIVITY/TARGET/NUM SERVED/OUTCOME
S:'$D(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDPRVA,ACDTRG,ACDOUTC)) ^(ACDOUTC)="" S ACDN0=^(ACDOUTC),$P(ACDN0,U)=$P(ACDN0,U)+1,$P(ACDN0,U,2)=$P(ACDN0,U,2)+ACDNUMR,^(ACDOUTC)=ACDN0
Q
310 ;;COMPONENT/ACTIVITY/TARGET/NUM SERVED
S:'$D(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDCOMCL_"/"_ACDCOMT,ACDPRVA,ACDTRG)) ^(ACDTRG)="" S ACDN0=^(ACDTRG),$P(ACDN0,U)=$P(ACDN0,U)+1,$P(ACDN0,U,2)=$P(ACDN0,U,2)+ACDNUMR,^(ACDTRG)=ACDN0
Q
G301 S ACDC(1)=ACDH(20),ACDC(2)=ACDH(19),ACDC(3)=ACDH(15),ACDC(4)=ACDH(7),ACDC(5)=ACDH(22) D ^ACDWRP25 Q
G302 S ACDC(1)=ACDH(19),ACDC(2)=ACDH(17),ACDC(5)=ACDH(22),ACDC(3)=ACDH(15),ACDC(4)=ACDH(7) D ^ACDWRP25 Q
G303 S ACDC(1)=ACDH(19),ACDC(2)=ACDH(17),ACDC(3)=ACDH(16),ACDC(4)=ACDH(7) D ^ACDWRP20 Q
G304 S ACDC(1)=ACDH(19),ACDC(2)=ACDH(17),ACDC(3)=ACDH(18),ACDC(4)=ACDH(7) D ^ACDWRP20 Q
G305 S ACDC(1)=ACDH(19),ACDC(2)=ACDH(17),ACDC(3)=ACDH(7) D ^ACDWRP21 Q
G306 S ACDC(1)=ACDH(19),ACDC(2)=ACDH(18),ACDC(3)=ACDH(7) D ^ACDWRP21 Q
G300 S ACDC(1)=ACDH(20),ACDC(2)=ACDH(19),ACDC(3)=ACDH(16),ACDC(4)=ACDH(7) D ^ACDWRP20 Q
G307 S ACDC(1)=ACDH(19),ACDC(2)=ACDH(16),ACDC(3)=ACDH(7) D ^ACDWRP21 Q
G308 S ACDC(1)=ACDH(19),ACDC(2)=ACDH(15),ACDC(3)=ACDH(7),ACDC(4)=ACDH(22) D ^ACDWRP22 Q
G309 S ACDC(1)=ACDH(19),ACDC(2)=ACDH(17),ACDC(3)=ACDH(15),ACDC(4)=ACDH(18),ACDC(5)=ACDH(7),ACDC(6)=ACDH(22) D ^ACDWRP26 Q
G310 S ACDC(1)=ACDH(20),ACDC(2)=ACDH(19),ACDC(3)=ACDH(17),ACDC(4)=ACDH(15),ACDC(5)=ACDH(7),ACDC(6)=ACDH(22) D ^ACDWRP27 Q
;
EOJ ;EP - EOJ FOR XBDBQUE
K ^TMP("ACD",ACDJOB,ACDBT)
LOCK -^TMP("ACD",ACDJOB,ACDBT)
K ACDNW,ACDQ,ACDFAC,ACDAREA,ACDSU,ACDTRB,ACDSTA
K ACDAGE,ACDBT,ACDFOLL,ACDH,ACDHRS,ACDJOB,ACDOK,ACDOPT,ACDPLAAL,ACDPLARL,ACDPT,ACDSTAT,ACDTG,ACDTGSUB,ACDVET,ACDWDRV
Q
ACDWDRV5 ;IHS/ADC/EDE/KML - DRV 5 REPORTS TAKEN FROM ACDPD GLOBAL;
+1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
+2 ;//[ACDR7MENU]
+3 FOR
KILL ACDQUIT
DO DIR
IF $DATA(ACDQUIT)
DO PRHDR^ACD
GOTO ^ACDWK
DIR ;Menu
+1 SET ACDWDRV(5)=5
+2 DO PRHDR^ACD
+3 ;S:'$D(ACD27) $P(ACD27,"*",27)="*"
+4 ;W !!,ACD27,!,"* CDMIS PREVENTION REPORTS *",!,ACD27,!
+5 FOR I=300:1:310
WRITE !,I," ",$PIECE($TEXT(@I),";",3)
IF I=310
SET DIR(0)="L^300:310^S ACDRPTS=Y"
SET DIR("A")="RUN REPORT # "
WRITE !
DO ^DIR
IF X["^"!($DATA(DTOUT))
SET ACDQUIT=1
IF $DATA(ACDQUIT)
QUIT
+6 IF $DATA(ACDQUIT)
KILL ACDWDRV
QUIT
+7 DO ^ACDWRQ
IF $DATA(ACDQUIT)
KILL ACDQUIT
QUIT
+8 ; call to XBDBQUE
DO ^ACDWQ
+9 QUIT
+10 ;
L ;EP - FOR TASKMAN
+1 SET ACDNW(1)=ACDTO
SET ACDNW(2)=ACDFR
SET ACDNW(3)=ACDLOC
SET ACDNW(4)=ACDRPTS
+2 SET ACDTO=ACDNW(1)
SET ACDFR=ACDNW(2)
SET ACDLOC=ACDNW(3)
+3 DO ACDV
+4 QUIT
+5 ;
+6 SET ACDDA=ACDDO
DO ^ACDWPD
IF ACDOK
FOR ACDA1=0:0
SET ACDA1=$ORDER(^ACDPD(ACDDO,1,ACDA1))
IF 'ACDA1
QUIT
DO M^ACDWPD
DO @ACDTG
ACDV ;
+1 KILL ^TMP("ACD",ACDJOB,ACDBT)
+2 FOR ACD=ACDFR-.001:0
SET ACD=$ORDER(^ACDPD("B",ACD))
IF 'ACD!(ACD>ACDTO)
QUIT
Begin DoDot:1
+3 SET ACDV=0
+4 FOR
SET ACDV=$ORDER(^ACDPD("B",ACD,ACDV))
IF 'ACDV
QUIT
SET ^TMP("ACD",ACDJOB,ACDBT,"HIT",ACDV)=""
+5 QUIT
End DoDot:1
+6 QUIT
+7 ;
P ;EP - PRINT REPORT
+1 KILL DIRUT
+2 SET ACDNW(1)=ACDTO
SET ACDNW(2)=ACDFR
SET ACDNW(3)=ACDLOC
SET ACDNW(4)=ACDRPTS
+3 FOR ACDNW(0)=1:1:$LENGTH(ACDNW(4),",")-1
SET ACDTO=ACDNW(1)
SET ACDFR=ACDNW(2)
SET ACDLOC=ACDNW(3)
SET (ACDTG,ACDTGSUB)=$PIECE(ACDNW(4),",",ACDNW(0))
DO P2
IF $DATA(DIRUT)
QUIT
+4 QUIT
+5 ;
P2 ;
+1 SET ACDV=0
+2 FOR
SET ACDV=$ORDER(^TMP("ACD",ACDJOB,ACDBT,"HIT",ACDV))
IF 'ACDV
QUIT
Begin DoDot:1
+3 SET ACDDA=ACDV
+4 DO ^ACDWPD
+5 IF 'ACDOK
QUIT
+6 SET ACDA1=0
+7 FOR
SET ACDA1=$ORDER(^ACDPD(ACDV,1,ACDA1))
IF 'ACDA1
QUIT
SET ACDDO=ACDV
DO M^ACDWPD
DO @ACDTG
+8 QUIT
End DoDot:1
IF $DATA(DIRUT)
QUIT
+9 DO HED
+10 QUIT
+11 ;
HED ;Header vars
+1 SET ACDH(0)=$PIECE($TEXT(@ACDTG),";",3)_U_ACDLOC
SET ACDWDRV(5)=5
DO HV^ACDWUTL
+2 USE IO
DO H
SET ACDTG="G"_ACDTG
DO @ACDTG
QUIT
H ;EP
+1 WRITE @IOF,!,"CDMIS PREVENTION REPORT # "_$SELECT(ACDTG:ACDTG,1:$EXTRACT(ACDTG,2,6)),!,$PIECE(ACDH(0),U)
SET ACDH(3)=ACDH(3)+1
WRITE ?68,"PG ",ACDH(3),!,ACDH(50),$PIECE(ACDH(0),U,2)
DO ASF^ACDWUTL
WRITE !,"DATA CAPTURED FOR: ",ACDH(2),!,ACDH(4),!
+2 QUIT
300 ;;COMPONENT/ACTIVITY/LOCATION
+1 IF '$DATA(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDCOMCL_"/"_ACDCOMT,ACDPRVA,ACDLOTY))
SET ^(ACDLOTY)=""
SET ^(ACDLOTY)=^(ACDLOTY)+1
QUIT
301 ;;COMPONENT/ACTIVITY/NUM SERVED
+1 IF '$DATA(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDCOMCL_"/"_ACDCOMT,ACDPRVA))
SET ^(ACDPRVA)=""
SET ACDN0=^(ACDPRVA)
SET $PIECE(ACDN0,U)=$PIECE(ACDN0,U)+1
SET $PIECE(ACDN0,U,2)=$PIECE(ACDN0,U,2)+ACDNUMR
SET ^(ACDPRVA)=ACDN0
QUIT
302 ;;ACTIVITY/TARGET/NUMBER SERVED
+1 IF '$DATA(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDPRVA,ACDTRG))
SET ^(ACDTRG)=""
SET ACDN0=^(ACDTRG)
SET $PIECE(ACDN0,U)=$PIECE(ACDN0,U)+1
SET $PIECE(ACDN0,U,2)=$PIECE(ACDN0,U,2)+ACDNUMR
SET ^(ACDTRG)=ACDN0
QUIT
303 ;;ACTIVITY/TARGET/LOCATION
+1 IF '$DATA(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDPRVA,ACDTRG,ACDLOTY))
SET ^(ACDLOTY)=""
SET ^(ACDLOTY)=^(ACDLOTY)+1
QUIT
304 ;;ACTIVITY/TARGET/OUTCOME
+1 IF '$DATA(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDPRVA,ACDTRG,ACDOUTC))
SET ^(ACDOUTC)=""
SET ^(ACDOUTC)=^(ACDOUTC)+1
QUIT
305 ;;ACTIVITY/TARGET
+1 IF '$DATA(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDPRVA,ACDTRG))
SET ^(ACDTRG)=""
SET ^(ACDTRG)=^(ACDTRG)+1
QUIT
306 ;;ACTIVITY/OUTCOME
+1 IF '$DATA(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDPRVA,ACDOUTC))
SET ^(ACDOUTC)=""
SET ^(ACDOUTC)=^(ACDOUTC)+1
QUIT
307 ;;ACTIVITY/LOCATION
+1 IF '$DATA(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDPRVA,ACDLOTY))
SET ^(ACDLOTY)=""
SET ^(ACDLOTY)=^(ACDLOTY)+1
QUIT
308 ;;ACTIVITY/#SERVED
+1 IF '$DATA(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDPRVA))
SET ^(ACDPRVA)=""
SET ACDN0=^(ACDPRVA)
SET $PIECE(ACDN0,U)=$PIECE(ACDN0,U)+1
SET $PIECE(ACDN0,U,2)=$PIECE(ACDN0,U,2)+ACDNUMR
SET ^(ACDPRVA)=ACDN0
QUIT
+2 QUIT
309 ;;ACTIVITY/TARGET/NUM SERVED/OUTCOME
+1 IF '$DATA(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDPRVA,ACDTRG,ACDOUTC))
SET ^(ACDOUTC)=""
SET ACDN0=^(ACDOUTC)
SET $PIECE(ACDN0,U)=$PIECE(ACDN0,U)+1
SET $PIECE(ACDN0,U,2)=$PIECE(ACDN0,U,2)+ACDNUMR
SET ^(ACDOUTC)=ACDN0
+2 QUIT
310 ;;COMPONENT/ACTIVITY/TARGET/NUM SERVED
+1 IF '$DATA(^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDCOMCL_"/"_ACDCOMT,ACDPRVA,ACDTRG))
SET ^(ACDTRG)=""
SET ACDN0=^(ACDTRG)
SET $PIECE(ACDN0,U)=$PIECE(ACDN0,U)+1
SET $PIECE(ACDN0,U,2)=$PIECE(ACDN0,U,2)+ACDNUMR
SET ^(ACDTRG)=ACDN0
+2 QUIT
G301 SET ACDC(1)=ACDH(20)
SET ACDC(2)=ACDH(19)
SET ACDC(3)=ACDH(15)
SET ACDC(4)=ACDH(7)
SET ACDC(5)=ACDH(22)
DO ^ACDWRP25
QUIT
G302 SET ACDC(1)=ACDH(19)
SET ACDC(2)=ACDH(17)
SET ACDC(5)=ACDH(22)
SET ACDC(3)=ACDH(15)
SET ACDC(4)=ACDH(7)
DO ^ACDWRP25
QUIT
G303 SET ACDC(1)=ACDH(19)
SET ACDC(2)=ACDH(17)
SET ACDC(3)=ACDH(16)
SET ACDC(4)=ACDH(7)
DO ^ACDWRP20
QUIT
G304 SET ACDC(1)=ACDH(19)
SET ACDC(2)=ACDH(17)
SET ACDC(3)=ACDH(18)
SET ACDC(4)=ACDH(7)
DO ^ACDWRP20
QUIT
G305 SET ACDC(1)=ACDH(19)
SET ACDC(2)=ACDH(17)
SET ACDC(3)=ACDH(7)
DO ^ACDWRP21
QUIT
G306 SET ACDC(1)=ACDH(19)
SET ACDC(2)=ACDH(18)
SET ACDC(3)=ACDH(7)
DO ^ACDWRP21
QUIT
G300 SET ACDC(1)=ACDH(20)
SET ACDC(2)=ACDH(19)
SET ACDC(3)=ACDH(16)
SET ACDC(4)=ACDH(7)
DO ^ACDWRP20
QUIT
G307 SET ACDC(1)=ACDH(19)
SET ACDC(2)=ACDH(16)
SET ACDC(3)=ACDH(7)
DO ^ACDWRP21
QUIT
G308 SET ACDC(1)=ACDH(19)
SET ACDC(2)=ACDH(15)
SET ACDC(3)=ACDH(7)
SET ACDC(4)=ACDH(22)
DO ^ACDWRP22
QUIT
G309 SET ACDC(1)=ACDH(19)
SET ACDC(2)=ACDH(17)
SET ACDC(3)=ACDH(15)
SET ACDC(4)=ACDH(18)
SET ACDC(5)=ACDH(7)
SET ACDC(6)=ACDH(22)
DO ^ACDWRP26
QUIT
G310 SET ACDC(1)=ACDH(20)
SET ACDC(2)=ACDH(19)
SET ACDC(3)=ACDH(17)
SET ACDC(4)=ACDH(15)
SET ACDC(5)=ACDH(7)
SET ACDC(6)=ACDH(22)
DO ^ACDWRP27
QUIT
+1 ;
EOJ ;EP - EOJ FOR XBDBQUE
+1 KILL ^TMP("ACD",ACDJOB,ACDBT)
+2 LOCK -^TMP("ACD",ACDJOB,ACDBT)
+3 KILL ACDNW,ACDQ,ACDFAC,ACDAREA,ACDSU,ACDTRB,ACDSTA
+4 KILL ACDAGE,ACDBT,ACDFOLL,ACDH,ACDHRS,ACDJOB,ACDOK,ACDOPT,ACDPLAAL,ACDPLARL,ACDPT,ACDSTAT,ACDTG,ACDTGSUB,ACDVET,ACDWDRV
+5 QUIT
