ACDWDRV3 ;IHS/ADC/EDE/KML - DRV 3 FOR CONFIDENTIAL CLIENT REPORTS;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
;//[ACDR4MENU]
;
F K ACDQUIT D DIR I $D(ACDQUIT) D PRHDR^ACD G ^ACDWK
DIR ;Menu
S ACDWDRV(3)=3
D PRHDR^ACD
;S:'$D(ACD56) $P(ACD56,"*",56)="*"
;W !,ACD56,!,"CLIENT DETAIL REPORTS",!,"CONFIDENTIAL CLIENT INFORMATION UNDER CFR 42 PART 2",!,ACD56,!
F I=100:1:107 W !,I," ",$P($T(@I),";",3) I I=107 S DIR(0)="L^100:107^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
;Run for selected patient or all patients
K ACDPT
S DIR("A")="SELECTION",DIR(0)="S^1:DISPLAY ALL PATIENTS;2:DISPLAY SELECTED PATIENTS" D ^DIR S:X["^"!($D(DTOUT))!(X="") ACDQUIT=1
Q:$D(ACDQUIT)
I X=2 D
.S DIC("A")="Inquire on patient: "
.S AUPNLK("ALL")=1
.F S DIC(0)="AEQM",DIC=9000001 D ^DIC Q:Y<0 S ACDPT(1_ACD6DIG_+Y)=""
.K AUPNLK("ALL")
.I '$D(ACDPT) S ACDQUIT=1
.Q
Q:$D(ACDQUIT)
D ^ACDWRQ I $D(ACDQUIT) K ACDQUIT Q
D ^ACDWQ ; call to XBDBQUE
Q
;
L ;EP - FOR TASKMAN
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 ACDV Q:$D(DIRUT)
Q ; ***** EDE/added this Q. Seems reasonable not to fall thru *****
ACDV ;Order on visit date
D @ACDTG
Q
100 ;;INITIAL
101 ;;REOPEN
102 ;;INFO/REFERRAL
103 ;;FOLLOWUP
104 ;;CRISIS/BRIEF INT
K ^TMP("ACD",ACDJOB,ACDBT) S ACDDO=0
F ACD=ACDFR-.01:0 S ACD=$O(^ACDVIS("B",ACD)) Q:'ACD!(ACD>ACDTO) S ACDV=0 F S ACDV=$O(^ACDVIS("B",ACD,ACDV)) Q:'ACDV S ACD1=0 F S ACD1=$O(^ACDIIF("C",ACDV,ACD1)) Q:'ACD1 S ACDDA=ACD1 D ^ACDWIIF S ACDDA=ACDV D ^ACDWVIS I ACDOK,ACDDFNP D B
G HED
;
105 ;;TRANS/DISC/CLOSE
K ^TMP("ACD",ACDJOB,ACDBT) S ACDDO=0
F ACD=ACDFR-.01:0 S ACD=$O(^ACDVIS("B",ACD)) Q:'ACD!(ACD>ACDTO) S ACDV=0 F S ACDV=$O(^ACDVIS("B",ACD,ACDV)) Q:'ACDV S ACD1=0 F S ACD1=$O(^ACDTDC("C",ACDV,ACD1)) Q:'ACD1 S ACDDA=ACD1 D ^ACDWTDC S ACDDA=ACDV D ^ACDWVIS I ACDOK,ACDDFNP D B
G HED
;
106 ;;CLIENT SERVICE
K ^TMP("ACD",ACDJOB,ACDBT) S ACDDO=0
S ACDFR=$E(ACDFR,1,5)_"00" ; date string manipulation (no day) in order for the CS visit x-ref in the visit file to be picked up
F ACD=ACDFR-.01:0 S ACD=$O(^ACDVIS("B",ACD)) Q:'ACD!(ACD>ACDTO) S ACDV=0 F S ACDV=$O(^ACDVIS("B",ACD,ACDV)) Q:'ACDV S ACD1=0 F S ACD1=$O(^ACDCS("C",ACDV,ACD1)) Q:'ACD1 S ACDDA=ACD1 D ^ACDWCS S ACDDA=ACDV D ^ACDWVIS I ACDOK,ACDDFNP D B
G HED
;
107 ;;INTERVENTIONS
K ^TMP("ACD",ACDJOB,ACDBT) S ACDDO=0
F ACD=ACDFR-.01:0 S ACD=$O(^ACDINTV("B",ACD)) Q:'ACD!(ACD>ACDTO) S ACD1=0 F S ACD1=$O(^ACDINTV("B",ACD,ACD1)) Q:'ACD1 S ACDDA=ACD1 D ^ACDWCINV,MATCH^ACDWVIS I ACDOK,ACDDFNP D B
G HED
;
B ;Build utility
;Only build data if the visit contact type meets the contact
;type requested by user
I ACDCONTL'=$P($T(@ACDTG),";",3) Q
;
;
;Check for selected patients only.
I $D(ACDPT),'$D(ACDPT(ACDDFNP)) Q
S ^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDDFN,ACD1)=""
Q
;
HED ;Set header variables
I '$D(^TMP("ACD",ACDJOB,ACDBT)) D RESET^ACDWUTL
S ACDH(0)=$P($T(@ACDTG),";",3)_U_ACDLOC,ACDWDRV(3)=3 D HV^ACDWUTL
U IO D H S ACDTG="G"_ACDTG D @ACDTG
Q
;
H ;EP
W @IOF,!,"CONFIDENTIAL CLIENT INFORMATION UNDER CFR 42 PART 2",!,"DETAILED CLIENT REPORT #",$S(ACDTG:ACDTG,1:$E(ACDTG,2,6)),!,"CONTACT TYPE: ",$P(ACDH(0),U) S ACDH(3)=ACDH(3)+1
I $D(ACDPT) W !,"SELECTED PATIENTS ONLY"
I ACDH(3)>1,$D(ACDDFN) W !,"PATIENT: ",ACDDFN
W ?68,"PG ",ACDH(3),!,ACDH(50),$P(ACDH(0),U,2),! D ASF^ACDWUTL W !,"DATA CAPTURED FOR: ",ACDH(2),!,ACDH(4),!
I ACDTG="G106"!(ACDTG=106) W !,"DAY",?5,"SERVICE",?33,"LOCATION",?50,"HRS",?71,"PROVIDER"
W !,ACDH(1)
Q
G100 ;
G101 ;
G102 D ^ACDWCD80 Q
G103 D ^ACDWCD70 Q
G104 D ^ACDWCD60 Q
G105 D ^ACDWCD2 Q
G106 D ^ACDWCD3 Q
G107 D ^ACDWCD4 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
ACDWDRV3 ;IHS/ADC/EDE/KML - DRV 3 FOR CONFIDENTIAL CLIENT REPORTS;
+1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
+2 ;//[ACDR4MENU]
+3 ;
+4 FOR
KILL ACDQUIT
DO DIR
IF $DATA(ACDQUIT)
DO PRHDR^ACD
GOTO ^ACDWK
DIR ;Menu
+1 SET ACDWDRV(3)=3
+2 DO PRHDR^ACD
+3 ;S:'$D(ACD56) $P(ACD56,"*",56)="*"
+4 ;W !,ACD56,!,"CLIENT DETAIL REPORTS",!,"CONFIDENTIAL CLIENT INFORMATION UNDER CFR 42 PART 2",!,ACD56,!
+5 FOR I=100:1:107
WRITE !,I," ",$PIECE($TEXT(@I),";",3)
IF I=107
SET DIR(0)="L^100:107^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 ;Run for selected patient or all patients
+8 KILL ACDPT
+9 SET DIR("A")="SELECTION"
SET DIR(0)="S^1:DISPLAY ALL PATIENTS;2:DISPLAY SELECTED PATIENTS"
DO ^DIR
IF X["^"!($DATA(DTOUT))!(X="")
SET ACDQUIT=1
+10 IF $DATA(ACDQUIT)
QUIT
+11 IF X=2
Begin DoDot:1
+12 SET DIC("A")="Inquire on patient: "
+13 SET AUPNLK("ALL")=1
+14 FOR
SET DIC(0)="AEQM"
SET DIC=9000001
DO ^DIC
IF Y<0
QUIT
SET ACDPT(1_ACD6DIG_+Y)=""
+15 KILL AUPNLK("ALL")
+16 IF '$DATA(ACDPT)
SET ACDQUIT=1
+17 QUIT
End DoDot:1
+18 IF $DATA(ACDQUIT)
QUIT
+19 DO ^ACDWRQ
IF $DATA(ACDQUIT)
KILL ACDQUIT
QUIT
+20 ; call to XBDBQUE
DO ^ACDWQ
+21 QUIT
+22 ;
L ;EP - FOR TASKMAN
+1 QUIT
+2 ;
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 ACDV
IF $DATA(DIRUT)
QUIT
+4 ; ***** EDE/added this Q. Seems reasonable not to fall thru *****
QUIT
ACDV ;Order on visit date
+1 DO @ACDTG
+2 QUIT
100 ;;INITIAL
101 ;;REOPEN
102 ;;INFO/REFERRAL
103 ;;FOLLOWUP
104 ;;CRISIS/BRIEF INT
+1 KILL ^TMP("ACD",ACDJOB,ACDBT)
SET ACDDO=0
+2 FOR ACD=ACDFR-.01:0
SET ACD=$ORDER(^ACDVIS("B",ACD))
IF 'ACD!(ACD>ACDTO)
QUIT
SET ACDV=0
FOR
SET ACDV=$ORDER(^ACDVIS("B",ACD,ACDV))
IF 'ACDV
QUIT
SET ACD1=0
FOR
SET ACD1=$ORDER(^ACDIIF("C",ACDV,ACD1))
IF 'ACD1
QUIT
SET ACDDA=ACD1
DO ^ACDWIIF
SET ACDDA=ACDV
DO ^ACDWVIS
IF ACDOK
IF ACDDFNP
DO B
+3 GOTO HED
+4 ;
105 ;;TRANS/DISC/CLOSE
+1 KILL ^TMP("ACD",ACDJOB,ACDBT)
SET ACDDO=0
+2 FOR ACD=ACDFR-.01:0
SET ACD=$ORDER(^ACDVIS("B",ACD))
IF 'ACD!(ACD>ACDTO)
QUIT
SET ACDV=0
FOR
SET ACDV=$ORDER(^ACDVIS("B",ACD,ACDV))
IF 'ACDV
QUIT
SET ACD1=0
FOR
SET ACD1=$ORDER(^ACDTDC("C",ACDV,ACD1))
IF 'ACD1
QUIT
SET ACDDA=ACD1
DO ^ACDWTDC
SET ACDDA=ACDV
DO ^ACDWVIS
IF ACDOK
IF ACDDFNP
DO B
+3 GOTO HED
+4 ;
106 ;;CLIENT SERVICE
+1 KILL ^TMP("ACD",ACDJOB,ACDBT)
SET ACDDO=0
+2 ; date string manipulation (no day) in order for the CS visit x-ref in the visit file to be picked up
SET ACDFR=$EXTRACT(ACDFR,1,5)_"00"
+3 FOR ACD=ACDFR-.01:0
SET ACD=$ORDER(^ACDVIS("B",ACD))
IF 'ACD!(ACD>ACDTO)
QUIT
SET ACDV=0
FOR
SET ACDV=$ORDER(^ACDVIS("B",ACD,ACDV))
IF 'ACDV
QUIT
SET ACD1=0
FOR
SET ACD1=$ORDER(^ACDCS("C",ACDV,ACD1))
IF 'ACD1
QUIT
SET ACDDA=ACD1
DO ^ACDWCS
SET ACDDA=ACDV
DO ^ACDWVIS
IF ACDOK
IF ACDDFNP
DO B
+4 GOTO HED
+5 ;
107 ;;INTERVENTIONS
+1 KILL ^TMP("ACD",ACDJOB,ACDBT)
SET ACDDO=0
+2 FOR ACD=ACDFR-.01:0
SET ACD=$ORDER(^ACDINTV("B",ACD))
IF 'ACD!(ACD>ACDTO)
QUIT
SET ACD1=0
FOR
SET ACD1=$ORDER(^ACDINTV("B",ACD,ACD1))
IF 'ACD1
QUIT
SET ACDDA=ACD1
DO ^ACDWCINV
DO MATCH^ACDWVIS
IF ACDOK
IF ACDDFNP
DO B
+3 GOTO HED
+4 ;
B ;Build utility
+1 ;Only build data if the visit contact type meets the contact
+2 ;type requested by user
+3 IF ACDCONTL'=$PIECE($TEXT(@ACDTG),";",3)
QUIT
+4 ;
+5 ;
+6 ;Check for selected patients only.
+7 IF $DATA(ACDPT)
IF '$DATA(ACDPT(ACDDFNP))
QUIT
+8 SET ^TMP("ACD",ACDJOB,ACDBT,ACDTGSUB,"VAL",ACDDFN,ACD1)=""
+9 QUIT
+10 ;
HED ;Set header variables
+1 IF '$DATA(^TMP("ACD",ACDJOB,ACDBT))
DO RESET^ACDWUTL
+2 SET ACDH(0)=$PIECE($TEXT(@ACDTG),";",3)_U_ACDLOC
SET ACDWDRV(3)=3
DO HV^ACDWUTL
+3 USE IO
DO H
SET ACDTG="G"_ACDTG
DO @ACDTG
+4 QUIT
+5 ;
H ;EP
+1 WRITE @IOF,!,"CONFIDENTIAL CLIENT INFORMATION UNDER CFR 42 PART 2",!,"DETAILED CLIENT REPORT #",$SELECT(ACDTG:ACDTG,1:$EXTRACT(ACDTG,2,6)),!,"CONTACT TYPE: ",$PIECE(ACDH(0),U)
SET ACDH(3)=ACDH(3)+1
+2 IF $DATA(ACDPT)
WRITE !,"SELECTED PATIENTS ONLY"
+3 IF ACDH(3)>1
IF $DATA(ACDDFN)
WRITE !,"PATIENT: ",ACDDFN
+4 WRITE ?68,"PG ",ACDH(3),!,ACDH(50),$PIECE(ACDH(0),U,2),!
DO ASF^ACDWUTL
WRITE !,"DATA CAPTURED FOR: ",ACDH(2),!,ACDH(4),!
+5 IF ACDTG="G106"!(ACDTG=106)
WRITE !,"DAY",?5,"SERVICE",?33,"LOCATION",?50,"HRS",?71,"PROVIDER"
+6 WRITE !,ACDH(1)
+7 QUIT
G100 ;
G101 ;
G102 DO ^ACDWCD80
QUIT
G103 DO ^ACDWCD70
QUIT
G104 DO ^ACDWCD60
QUIT
G105 DO ^ACDWCD2
QUIT
G106 DO ^ACDWCD3
QUIT
G107 DO ^ACDWCD4
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
