ACDDEU ;IHS/ADC/EDE/KML - COMMON FUNCTIONS;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
;
DEV ; EP - SELECT OUTPUT DEVICE
K ACDSLAVE
S ACDQ=0
S %ZIS="Q",%ZIS("B")="" D ^%ZIS
I POP S ACDQ=1
I $D(IO("S")) S ACDSLAVE=ION W @IOF D ^%ZISC
Q
;
PAUSE ; EP - PAUSE FOR USER
Q:$E(IOST)'="C"
Q:$D(ZTQUEUED)!'(IOT["TRM")!$D(IO("S")) ;*** TESTING - AEF *** CHANGED ="TRM" TO ["TRM" TO ACCOUNT FOR "VTRM"
S DIR(0)="E",DIR("A")="Press any key to continue"
K DIRUT
D ^DIR K DIR
Q
;
CONF ; EP - CONFIDENTIAL CLIENT DATA HEADER
W !,"*** CONFIDENTIAL CLIENT INFORMATION UNDER CFR 42 PART 2 ***",!
NEW X,Y
D NOW^%DTC S Y=$$DD^ACDFUNC(%) W !,"PRINTED: "_Y_" BY: "_$P($G(^VA(200,DUZ,0)),U)_"@"_ACDSITE,!
S X="",$P(X,"=",79)="" W X,!
Q
;
HDR ; EP - DISPLAY HEADER
D HDR2
S X="",$P(X,"-",79)=""
W X,!
K X
Q
;
HDR2 ;
W @IOF,"Signon Program is : ",$P(^DIC(4,DUZ(2),0),U),!
I ACDMODE="A" D
. W "Records that may be added are: THOSE WITHIN YOUR SIGNIN PROGRAM.",!!
. W "ADDING CDMIS VISIT RECORDS...",!!
. Q
I ACDMODE="E" D
. W "Editable Records are: THOSE NOT EXTRACTED.",!
. W " THOSE WITHIN YOUR SIGNIN PROGRAM.",!!
. W "EDITING CDMIS VISIT RECORDS...",!!
. Q
Q:$G(ACDCOMCL)=""
W "COMPONENT (CODE) : ",ACDCOMCL,!
W "COMPONENT (TYPE) : ",ACDCOMTL,!
I ACDLPTYP=1 Q:$G(ACDPROV)="" W !,"PRIMARY PROVIDER : ",ACDPROVN,!
Q:ACDCONTL=""
W !,"TYPE CONTACT : ",ACDCONTL,!
I ACDLPTYP=2,$G(ACDCSDP)'="" W "DEFAULT PROVIDER : ",ACDCSDP,!
Q:ACDVDTE=""
W "VISIT DATE : ",ACDVDTE,!
Q
;
DSPVSIT(VISIT) ; EP - DISPLAY CDMIS VISIT ENTRY
Q:'VISIT
S DIC="^ACDVIS(",DA=VISIT,DR=0
D DIQ^ACDFMC
Q
;
DSPHIST ; EP - DISPLAY CDMIS VISIT HISTORY
I '$D(^TMP("ACD",$J,"VISITS")) D Q
. W !,"----------",!
. W "No CDMIS VISIT history for client ",ACDDFN,!
. W "----------",!
. Q
I $E(IOST,1,2)="P-" D FWD I 1
E D BCK
Q
;
FWD ; FORWARD DISPLAY FOR PRINTERS ONLY
D CONF W !
W "CDMIS VISIT history for client ",ACDDFN,!!
W "----------",!
S ACDX=0
F S ACDX=$O(^TMP("ACD",$J,"VISITS",ACDX)) Q:ACDX="" S ACDY=0 F S ACDY=$O(^TMP("ACD",$J,"VISITS",ACDX,ACDY)) Q:'ACDY D DSPV I $P(^ACDVIS(ACDY,0),U,4)="CS" S ACDVIEN=ACDY D DSPCSH
W "----------",!
Q
;
BCK ; BACKWARD DISPLAY FOR CRTS
W !,"----------",!
W "Recent CDMIS VISIT history for client ",ACDDFN,!!
S ACDX="A",ACDCNT=0
F Q:ACDX="Q" S ACDX=$O(^TMP("ACD",$J,"VISITS",ACDX),-1) Q:ACDX="" S ACDY=0 F S ACDY=$O(^TMP("ACD",$J,"VISITS",ACDX,ACDY)) Q:'ACDY D DSPV S ACDCNT=ACDCNT+1 I ACDCNT>17 S ACDX="Q" Q
K ACDCNT
W "----------",!
Q
;
DSPV ; EP-DISPLAY CDMIS VISIT ENTRY
S DIC="9002172.1",DA=ACDY,DR=".01;1;3;5",DIQ="ACDPDD("
D DIQ1^ACDFMC
W ACDPDD(9002172.1,ACDY,.01),?12," - ",ACDPDD(9002172.1,ACDY,1),"/",ACDPDD(9002172.1,ACDY,5),?52,ACDPDD(9002172.1,ACDY,3),?70,$S($P(^ACDVIS(ACDY,0),U,25):" <EXTR>",1:""),!
K ACDPDD
Q
;
DSPCSH ; EP-DISPLAY CDMIS CLIENT SERVICE HISTORY FOR ONE CS VISIT
K ^TMP("ACD",$J,"CS")
S Y=0
F S Y=$O(^ACDCS("C",ACDVIEN,Y)) Q:'Y S X=^ACDCS(Y,0),^TMP("ACD",$J,"CS",$P(X,U),Y)=$P(X,U,2)
S Y=0
F S Y=$O(^TMP("ACD",$J,"CS",Y)) Q:'Y S Z=0 F S Z=$O(^TMP("ACD",$J,"CS",Y,Z)) Q:'Z D
. S X=^TMP("ACD",$J,"CS",Y,Z)
. D PFTV^XBPFTV(9002170.6,X,.W)
. W ?15,Y,?19,W,?55,$J(+$P(^ACDCS(Z,0),U,4),5,2)_" h",!
. Q
K ^TMP("ACD",$J,"CS")
Q
;
GETVSITS ; EP - GET CDMIS VISITS FOR THIS CLIENT
K ^TMP("ACD",$J,"VISITS")
S ACDVCNT=0,Y=0
F S Y=$O(^ACDVIS("D",ACDDFNP,Y)) Q:'Y S X=^ACDVIS(Y,0) I $P($G(^("BWP")),U)=ACDPGM D
. I $G(ACDTCTG)'="",$P(X,U,4)'=ACDTCTG Q ; quit if tc not wanted
. S ^TMP("ACD",$J,"VISITS",$P(X,U),Y)=X,ACDVCNT=ACDVCNT+1
. Q
Q
;
CHKFIN ; EP - CHECK FOR INITIAL CONTACT TYPE
I '$D(IORVON) S X="IORVON;IORVOFF" D ENDR^%ZISS
S ACDX="",(ACDY,Y)=0
F S ACDX=$O(^TMP("ACD",$J,"VISITS",ACDX)) Q:ACDX="" S Y=0 F S Y=$O(^TMP("ACD",$J,"VISITS",ACDX,Y)) Q:'Y S X=^(Y) I $P(X,U,2)=ACDCOMC,$P(X,U,7)=ACDCOMT,$P(X,U,4)="IN" S ACDY=Y Q
I ACDY,'ACDINR W !,IORVON,"INITIAL type contact already exists for patient ",ACDDFN,!,"in the ",ACDCOMCL,"/",ACDCOMTL," component.",IORVOFF,! D DSPVSIT^ACDDEU(ACDY),PAUSE^ACDDEU S ACDQ=1 Q
Q:ACDY ; quit if INITIAL type contact found
Q:'ACDINR ; quit if INITIAL type contact not required.
S ACDQ=1
W !,IORVON,"No INITIAL type contact for patient ",ACDDFN,!,"in the ",ACDCOMCL,"/",ACDCOMTL," component.",IORVOFF,!!,"Now searching for a REOPEN.",!
S ACDX="",(ACDY,Y)=0
F S ACDX=$O(^TMP("ACD",$J,"VISITS",ACDX)) Q:ACDX="" S Y=0 F S Y=$O(^TMP("ACD",$J,"VISITS",ACDX,Y)) Q:'Y S X=^(Y) I $P(X,U,2)=ACDCOMC,$P(X,U,7)=ACDCOMT,$P(X,U,4)="RE" S ACDY=Y Q
I ACDY S ACDQ=0 W !,"REOPEN found.",! Q
W !,IORVON,"No INITIAL or REOPEN found.",IORVOFF,!
D PAUSE^ACDDEU
Q
;
GETDTR ; EP-GET DATE RANGE
; returns ACDDTLO and ACDDTHI or ACDQ=1
F D GETDTR2 Q:$D(DIRUT) Q:'ACDQ
K:ACDQ ACDDTLO,ACDDTHI
Q
;
GETDTR2 ;
S ACDQ=1
S DIR(0)="DO^::EP",DIR("A")="Enter beginning date" K DA D ^DIR K DIR
Q:$D(DIRUT)
Q:Y=""
S ACDDTLO=Y
S DIR(0)="DO^::EP",DIR("A")="Enter ending date" K DA D ^DIR K DIR
Q:$D(DIRUT)
Q:Y=""
S ACDDTHI=Y
I ACDDTHI<ACDDTLO W !!,"Ending date before beginning date!",!! Q
S:$E(ACDDTLO,6,7)="01" $E(ACDDTLO,6,7)="00" ; to get CS visits
S ACDQ=0
Q
GETTOB ; get tobacco use info
; utilized by input templates ACD I/I/F ADD and ACD T/D/C/ ADD
N DIR S DIR(0)="S^0:NONE;1:SMOKING;2:SMOKELESS;3:SMOKING & SMOKELESS",DIR("A")="TOBACCO USE" D ^DIR
I Y N DR S DR="30///^S X=Y" D ^DIE
Q
ACDDEU ;IHS/ADC/EDE/KML - COMMON FUNCTIONS;
+1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
+2 ;
DEV ; EP - SELECT OUTPUT DEVICE
+1 KILL ACDSLAVE
+2 SET ACDQ=0
+3 SET %ZIS="Q"
SET %ZIS("B")=""
DO ^%ZIS
+4 IF POP
SET ACDQ=1
+5 IF $DATA(IO("S"))
SET ACDSLAVE=ION
WRITE @IOF
DO ^%ZISC
+6 QUIT
+7 ;
PAUSE ; EP - PAUSE FOR USER
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 ;*** TESTING - AEF *** CHANGED ="TRM" TO ["TRM" TO ACCOUNT FOR "VTRM"
IF $DATA(ZTQUEUED)!'(IOT["TRM")!$DATA(IO("S"))
QUIT
+3 SET DIR(0)="E"
SET DIR("A")="Press any key to continue"
+4 KILL DIRUT
+5 DO ^DIR
KILL DIR
+6 QUIT
+7 ;
CONF ; EP - CONFIDENTIAL CLIENT DATA HEADER
+1 WRITE !,"*** CONFIDENTIAL CLIENT INFORMATION UNDER CFR 42 PART 2 ***",!
+2 NEW X,Y
+3 DO NOW^%DTC
SET Y=$$DD^ACDFUNC(%)
WRITE !,"PRINTED: "_Y_" BY: "_$PIECE($GET(^VA(200,DUZ,0)),U)_"@"_ACDSITE,!
+4 SET X=""
SET $PIECE(X,"=",79)=""
WRITE X,!
+5 QUIT
+6 ;
HDR ; EP - DISPLAY HEADER
+1 DO HDR2
+2 SET X=""
SET $PIECE(X,"-",79)=""
+3 WRITE X,!
+4 KILL X
+5 QUIT
+6 ;
HDR2 ;
+1 WRITE @IOF,"Signon Program is : ",$PIECE(^DIC(4,DUZ(2),0),U),!
+2 IF ACDMODE="A"
Begin DoDot:1
+3 WRITE "Records that may be added are: THOSE WITHIN YOUR SIGNIN PROGRAM.",!!
+4 WRITE "ADDING CDMIS VISIT RECORDS...",!!
+5 QUIT
End DoDot:1
+6 IF ACDMODE="E"
Begin DoDot:1
+7 WRITE "Editable Records are: THOSE NOT EXTRACTED.",!
+8 WRITE " THOSE WITHIN YOUR SIGNIN PROGRAM.",!!
+9 WRITE "EDITING CDMIS VISIT RECORDS...",!!
+10 QUIT
End DoDot:1
+11 IF $GET(ACDCOMCL)=""
QUIT
+12 WRITE "COMPONENT (CODE) : ",ACDCOMCL,!
+13 WRITE "COMPONENT (TYPE) : ",ACDCOMTL,!
+14 IF ACDLPTYP=1
IF $GET(ACDPROV)=""
QUIT
WRITE !,"PRIMARY PROVIDER : ",ACDPROVN,!
+15 IF ACDCONTL=""
QUIT
+16 WRITE !,"TYPE CONTACT : ",ACDCONTL,!
+17 IF ACDLPTYP=2
IF $GET(ACDCSDP)'=""
WRITE "DEFAULT PROVIDER : ",ACDCSDP,!
+18 IF ACDVDTE=""
QUIT
+19 WRITE "VISIT DATE : ",ACDVDTE,!
+20 QUIT
+21 ;
DSPVSIT(VISIT) ; EP - DISPLAY CDMIS VISIT ENTRY
+1 IF 'VISIT
QUIT
+2 SET DIC="^ACDVIS("
SET DA=VISIT
SET DR=0
+3 DO DIQ^ACDFMC
+4 QUIT
+5 ;
DSPHIST ; EP - DISPLAY CDMIS VISIT HISTORY
+1 IF '$DATA(^TMP("ACD",$JOB,"VISITS"))
Begin DoDot:1
+2 WRITE !,"----------",!
+3 WRITE "No CDMIS VISIT history for client ",ACDDFN,!
+4 WRITE "----------",!
+5 QUIT
End DoDot:1
QUIT
+6 IF $EXTRACT(IOST,1,2)="P-"
DO FWD
IF 1
+7 IF '$TEST
DO BCK
+8 QUIT
+9 ;
FWD ; FORWARD DISPLAY FOR PRINTERS ONLY
+1 DO CONF
WRITE !
+2 WRITE "CDMIS VISIT history for client ",ACDDFN,!!
+3 WRITE "----------",!
+4 SET ACDX=0
+5 FOR
SET ACDX=$ORDER(^TMP("ACD",$JOB,"VISITS",ACDX))
IF ACDX=""
QUIT
SET ACDY=0
FOR
SET ACDY=$ORDER(^TMP("ACD",$JOB,"VISITS",ACDX,ACDY))
IF 'ACDY
QUIT
DO DSPV
IF $PIECE(^ACDVIS(ACDY,0),U,4)="CS"
SET ACDVIEN=ACDY
DO DSPCSH
+6 WRITE "----------",!
+7 QUIT
+8 ;
BCK ; BACKWARD DISPLAY FOR CRTS
+1 WRITE !,"----------",!
+2 WRITE "Recent CDMIS VISIT history for client ",ACDDFN,!!
+3 SET ACDX="A"
SET ACDCNT=0
+4 FOR
IF ACDX="Q"
QUIT
SET ACDX=$ORDER(^TMP("ACD",$JOB,"VISITS",ACDX),-1)
IF ACDX=""
QUIT
SET ACDY=0
FOR
SET ACDY=$ORDER(^TMP("ACD",$JOB,"VISITS",ACDX,ACDY))
IF 'ACDY
QUIT
DO DSPV
SET ACDCNT=ACDCNT+1
IF ACDCNT>17
SET ACDX="Q"
QUIT
+5 KILL ACDCNT
+6 WRITE "----------",!
+7 QUIT
+8 ;
DSPV ; EP-DISPLAY CDMIS VISIT ENTRY
+1 SET DIC="9002172.1"
SET DA=ACDY
SET DR=".01;1;3;5"
SET DIQ="ACDPDD("
+2 DO DIQ1^ACDFMC
+3 WRITE ACDPDD(9002172.1,ACDY,.01),?12," - ",ACDPDD(9002172.1,ACDY,1),"/",ACDPDD(9002172.1,ACDY,5),?52,ACDPDD(9002172.1,ACDY,3),?70,$SELECT($PIECE(^ACDVIS(ACDY,0),U,25):" <EXTR>",1:""),!
+4 KILL ACDPDD
+5 QUIT
+6 ;
DSPCSH ; EP-DISPLAY CDMIS CLIENT SERVICE HISTORY FOR ONE CS VISIT
+1 KILL ^TMP("ACD",$JOB,"CS")
+2 SET Y=0
+3 FOR
SET Y=$ORDER(^ACDCS("C",ACDVIEN,Y))
IF 'Y
QUIT
SET X=^ACDCS(Y,0)
SET ^TMP("ACD",$JOB,"CS",$PIECE(X,U),Y)=$PIECE(X,U,2)
+4 SET Y=0
+5 FOR
SET Y=$ORDER(^TMP("ACD",$JOB,"CS",Y))
IF 'Y
QUIT
SET Z=0
FOR
SET Z=$ORDER(^TMP("ACD",$JOB,"CS",Y,Z))
IF 'Z
QUIT
Begin DoDot:1
+6 SET X=^TMP("ACD",$JOB,"CS",Y,Z)
+7 DO PFTV^XBPFTV(9002170.6,X,.W)
+8 WRITE ?15,Y,?19,W,?55,$JUSTIFY(+$PIECE(^ACDCS(Z,0),U,4),5,2)_" h",!
+9 QUIT
End DoDot:1
+10 KILL ^TMP("ACD",$JOB,"CS")
+11 QUIT
+12 ;
GETVSITS ; EP - GET CDMIS VISITS FOR THIS CLIENT
+1 KILL ^TMP("ACD",$JOB,"VISITS")
+2 SET ACDVCNT=0
SET Y=0
+3 FOR
SET Y=$ORDER(^ACDVIS("D",ACDDFNP,Y))
IF 'Y
QUIT
SET X=^ACDVIS(Y,0)
IF $PIECE($GET(^("BWP")),U)=ACDPGM
Begin DoDot:1
+4 ; quit if tc not wanted
IF $GET(ACDTCTG)'=""
IF $PIECE(X,U,4)'=ACDTCTG
QUIT
+5 SET ^TMP("ACD",$JOB,"VISITS",$PIECE(X,U),Y)=X
SET ACDVCNT=ACDVCNT+1
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
CHKFIN ; EP - CHECK FOR INITIAL CONTACT TYPE
+1 IF '$DATA(IORVON)
SET X="IORVON;IORVOFF"
DO ENDR^%ZISS
+2 SET ACDX=""
SET (ACDY,Y)=0
+3 FOR
SET ACDX=$ORDER(^TMP("ACD",$JOB,"VISITS",ACDX))
IF ACDX=""
QUIT
SET Y=0
FOR
SET Y=$ORDER(^TMP("ACD",$JOB,"VISITS",ACDX,Y))
IF 'Y
QUIT
SET X=^(Y)
IF $PIECE(X,U,2)=ACDCOMC
IF $PIECE(X,U,7)=ACDCOMT
IF $PIECE(X,U,4)="IN"
SET ACDY=Y
QUIT
+4 IF ACDY
IF 'ACDINR
WRITE !,IORVON,"INITIAL type contact already exists for patient ",ACDDFN,!,"in the ",ACDCOMCL,"/",ACDCOMTL," component.",IORVOFF,!
DO DSPVSIT^ACDDEU(ACDY)
DO PAUSE^ACDDEU
SET ACDQ=1
QUIT
+5 ; quit if INITIAL type contact found
IF ACDY
QUIT
+6 ; quit if INITIAL type contact not required.
IF 'ACDINR
QUIT
+7 SET ACDQ=1
+8 WRITE !,IORVON,"No INITIAL type contact for patient ",ACDDFN,!,"in the ",ACDCOMCL,"/",ACDCOMTL," component.",IORVOFF,!!,"Now searching for a REOPEN.",!
+9 SET ACDX=""
SET (ACDY,Y)=0
+10 FOR
SET ACDX=$ORDER(^TMP("ACD",$JOB,"VISITS",ACDX))
IF ACDX=""
QUIT
SET Y=0
FOR
SET Y=$ORDER(^TMP("ACD",$JOB,"VISITS",ACDX,Y))
IF 'Y
QUIT
SET X=^(Y)
IF $PIECE(X,U,2)=ACDCOMC
IF $PIECE(X,U,7)=ACDCOMT
IF $PIECE(X,U,4)="RE"
SET ACDY=Y
QUIT
+11 IF ACDY
SET ACDQ=0
WRITE !,"REOPEN found.",!
QUIT
+12 WRITE !,IORVON,"No INITIAL or REOPEN found.",IORVOFF,!
+13 DO PAUSE^ACDDEU
+14 QUIT
+15 ;
GETDTR ; EP-GET DATE RANGE
+1 ; returns ACDDTLO and ACDDTHI or ACDQ=1
+2 FOR
DO GETDTR2
IF $DATA(DIRUT)
QUIT
IF 'ACDQ
QUIT
+3 IF ACDQ
KILL ACDDTLO,ACDDTHI
+4 QUIT
+5 ;
GETDTR2 ;
+1 SET ACDQ=1
+2 SET DIR(0)="DO^::EP"
SET DIR("A")="Enter beginning date"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
QUIT
+4 IF Y=""
QUIT
+5 SET ACDDTLO=Y
+6 SET DIR(0)="DO^::EP"
SET DIR("A")="Enter ending date"
KILL DA
DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)
QUIT
+8 IF Y=""
QUIT
+9 SET ACDDTHI=Y
+10 IF ACDDTHI<ACDDTLO
WRITE !!,"Ending date before beginning date!",!!
QUIT
+11 ; to get CS visits
IF $EXTRACT(ACDDTLO,6,7)="01"
SET $EXTRACT(ACDDTLO,6,7)="00"
+12 SET ACDQ=0
+13 QUIT
GETTOB ; get tobacco use info
+1 ; utilized by input templates ACD I/I/F ADD and ACD T/D/C/ ADD
+2 NEW DIR
SET DIR(0)="S^0:NONE;1:SMOKING;2:SMOKELESS;3:SMOKING & SMOKELESS"
SET DIR("A")="TOBACCO USE"
DO ^DIR
+3 IF Y
NEW DR
SET DR="30///^S X=Y"
DO ^DIE
+4 QUIT
