- 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
