ACDPVDSP ;IHS/ADC/EDE/KML - DISPLAY PATIENT VISIT;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
;
; This routine displays a patient's CDMIS visit with subordinate
; file entries.
;
START ;
W !
F D PATLOOP Q:ACDQ
D EOJ
Q
;
PATLOOP ; DISPLAY PATIENTS UNTIL DONE
D GETPAT
Q:ACDQ
D GETVSITS^ACDDEU ; gather all visits for patient
Q:ACDQ
D SELECT ; select visit to display
Q:ACDQ
D DISPLAY
D DEV^ACDDEU Q:ACDQ
I $D(ACDSLAVE)!(IO'=IO(0)) D DISPTAG
K ACDSLAVE S IO=IO(0)
U 0
Q
;
GETPAT ; GET PATIENT
S ACDQ=1
S AUPNLK("ALL")=1
S DIC="^AUPNPAT(",DIC(0)="AEMQ",DIC("S")="I $D(^ACDVIS(""D"",+Y))" D DIC^ACDFMC
K AUPNLK("ALL")
Q:Y<0
S ACDDFNP=+Y,ACDDFN=$P(^DPT(ACDDFNP,0),U)
S ACDQ=0
Q
;
SELECT ; SELECT A CDMIS VISIT
S ACDQ=1
W !
S ACDVIEN=0
K ACDVLST
I $O(^TMP("ACD",$J,"VISITS",0))="" W !,"----------",!,"No CDMIS visits!",!,"----------",! Q
S ACDDTLOW=0,ACDDTHI=9999999
I ACDVCNT>20 D GETDTRNG Q:ACDQ W !
S ACDQ=1
W !
S ACDLC=0
S ACDX=ACDDTLOW S:ACDX>0 ACDX=ACDX-1
F S ACDX=$O(^TMP("ACD",$J,"VISITS",ACDX)) Q:ACDX="" I ACDX'<ACDDTLOW,ACDX'>ACDDTHI S ACDY=0 F S ACDY=$O(^TMP("ACD",$J,"VISITS",ACDX,ACDY)) Q:'ACDY D Q:ACDQ
. S ACDQ=0
. S ACDLC=ACDLC+1
. S ACDVLST(ACDLC)=ACDY
. S DIC="9002172.1",DA=ACDY,DR=".01;1;3;5",DIQ="ACDPDD("
. D DIQ1^ACDFMC
. W ACDLC,?5,ACDPDD(9002172.1,ACDY,.01),?18," - ",ACDPDD(9002172.1,ACDY,1),"/",ACDPDD(9002172.1,ACDY,5)," ",ACDPDD(9002172.1,ACDY,3),!
. K ACDPDD
. I '(ACDLC#20) D PAUSE^ACDDEU S:$D(DIRUT) ACDQ=1
. Q
S ACDQ=1
I 'ACDLC W !,"No visits in date range",! Q
S DIR(0)="NO^1:"_ACDLC,DIR("A")="Select one of the listed visits" K DA D ^DIR K DIR
S:Y ACDVIEN=ACDVLST(Y)
K ACDLC,ACDVLST
Q:'ACDVIEN
S ACDQ=0
Q
;
GETDTRNG ; GET DATE RANGE FOR VISIT
S ACDQ=1
S ACDDTLOW=$O(^TMP("ACD",$J,"VISITS",0)),ACDDTHI=$O(^TMP("ACD",$J,"VISITS","Z"),-1)
W !,"Patient has ",ACDVCNT," visits between ",$$FMTE^XLFDT(ACDDTLOW,"1")," and ",$$FMTE^XLFDT(ACDDTHI,"1"),".",!,"Enter date range of desired visit.",!
S DIR(0)="DO^::E",DIR("A")="Enter beginning date" K DA D ^DIR K DIR
Q:'Y
S ACDDTLOW=Y
S DIR(0)="D^"_Y_"::E",DIR("A")="Enter ending date",DIR("B")=X K DA D ^DIR K DIR
Q:$D(DIRUT)
S ACDDTHI=Y
S ACDQ=0
Q
;
DISPLAY ; EP - DISPLAY VISIT AND SUBORDINATE FILE ENTRIES
I $O(^ACDVIS(ACDVIEN,21,0)) D
. W !!,"This CDMIS visit has linked PCC visits."
. S DIR(0)="Y",DIR("A")="Do you want to display the PCC visits also",DIR("B")="N" K DA D ^DIR K DIR
. S:Y ACDPCCL=1
. Q
DISPTAG I $D(IO("Q")) D Q
. S ZTRTN="DISPLAYQ^ACDPVDSP",ZTDESC="CDMIS VISIT DISPLAY",ZTDTH=$H,ZTSAVE("ACD*")=""
. D ^%ZTLOAD
. Q
D DISPLAYQ S ACDQ=0
Q
;
DISPLAYQ ; EP - FOR TASKMAN
I $D(ACDSLAVE) S IOP=ACDSLAVE D ^%ZIS
U IO
W:IO'=IO(0) @IOF
D:$E(IOST,1,2)="P-" CONF^ACDDEU
W !
D DSPVSIT^ACDDEU(ACDVIEN)
D:$E(IOST,1,2)'="P-" PAUSE^ACDDEU
Q:$D(DIRUT)
S X=$P(^ACDVIS(ACDVIEN,0),U,4)
I X'="IN",X'="RE",X'="FU",X'="IR",X'="OT",X'="TD",X'="CS" W !,"INVALID TYPE CONTACT",!
E S ACDCONT=X D @("DSP"_ACDCONT)
I $G(ACDPCCL) NEW ACDPCCV S ACDPCCL=0 F S ACDPCCL=$O(^ACDVIS(ACDVIEN,21,ACDPCCL)) Q:'ACDPCCL S ACDPCCV=$P(^(ACDPCCL,0),U,2) I ACDPCCV S APCDVDSP=ACDPCCV D ^APCDVDSP Q:$D(DIRUT)
I $D(ACDSLAVE) W @IOF D ^%ZISC
I $D(ZTQUEUED) D EOJ S ZTREQ="@"
Q
;
DSPIN ; DISPLAY INITIAL
D DSPIIF
Q
;
DSPRE ; DISPLAY REOPEN
D DSPIIF
Q
;
DSPFU ; DISPLAY FOLLOWUP
D DSPIIF
Q
;
DSPIR ; DISPLAY INFO/REFERRAL
D DSPIIF
Q
;
DSPOT ; DISPLAY CRISIS BRIEF
D DSPIIF
Q
;
DSPIIF ; DISPLAY IIF ENTRY
S DIC="^ACDIIF(",DA=$O(^ACDIIF("C",ACDVIEN,0))
I 'DA W !,"NO IIF ENTRY TO DISPLAY",!
E D DIQ^ACDFMC
D:$E(IOST,1,2)'="P-" PAUSE^ACDDEU
Q
;
DSPTD ; DISPLAY TDC ENTRY
S DIC="^ACDTDC(",DA=$O(^ACDTDC("C",ACDVIEN,0))
I 'DA W !,"NO TDC ENTRY TO DISPLAY",!
E D DIQ^ACDFMC
D:$E(IOST,1,2)'="P-" PAUSE^ACDDEU
Q
;
DSPCS ; DISPLAY CLIENT SERVICES
S ACDY=0
S ACDQ=0
F S ACDY=$O(^ACDCS("C",ACDVIEN,ACDY)) Q:'ACDY D Q:$D(DIRUT)
. S DIC="^ACDCS(",DA=ACDY
. D DIQ^ACDFMC
. I $E(IOST,1,2)'="P-" D PAUSE^ACDDEU
. Q
S ACDQ=0
Q
;
EOJ ;
D ^%ZISC
D ^ACDKILL
Q
ACDPVDSP ;IHS/ADC/EDE/KML - DISPLAY PATIENT VISIT;
+1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
+2 ;
+3 ; This routine displays a patient's CDMIS visit with subordinate
+4 ; file entries.
+5 ;
START ;
+1 WRITE !
+2 FOR
DO PATLOOP
IF ACDQ
QUIT
+3 DO EOJ
+4 QUIT
+5 ;
PATLOOP ; DISPLAY PATIENTS UNTIL DONE
+1 DO GETPAT
+2 IF ACDQ
QUIT
+3 ; gather all visits for patient
DO GETVSITS^ACDDEU
+4 IF ACDQ
QUIT
+5 ; select visit to display
DO SELECT
+6 IF ACDQ
QUIT
+7 DO DISPLAY
+8 DO DEV^ACDDEU
IF ACDQ
QUIT
+9 IF $DATA(ACDSLAVE)!(IO'=IO(0))
DO DISPTAG
+10 KILL ACDSLAVE
SET IO=IO(0)
+11 USE 0
+12 QUIT
+13 ;
GETPAT ; GET PATIENT
+1 SET ACDQ=1
+2 SET AUPNLK("ALL")=1
+3 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
SET DIC("S")="I $D(^ACDVIS(""D"",+Y))"
DO DIC^ACDFMC
+4 KILL AUPNLK("ALL")
+5 IF Y<0
QUIT
+6 SET ACDDFNP=+Y
SET ACDDFN=$PIECE(^DPT(ACDDFNP,0),U)
+7 SET ACDQ=0
+8 QUIT
+9 ;
SELECT ; SELECT A CDMIS VISIT
+1 SET ACDQ=1
+2 WRITE !
+3 SET ACDVIEN=0
+4 KILL ACDVLST
+5 IF $ORDER(^TMP("ACD",$JOB,"VISITS",0))=""
WRITE !,"----------",!,"No CDMIS visits!",!,"----------",!
QUIT
+6 SET ACDDTLOW=0
SET ACDDTHI=9999999
+7 IF ACDVCNT>20
DO GETDTRNG
IF ACDQ
QUIT
WRITE !
+8 SET ACDQ=1
+9 WRITE !
+10 SET ACDLC=0
+11 SET ACDX=ACDDTLOW
IF ACDX>0
SET ACDX=ACDX-1
+12 FOR
SET ACDX=$ORDER(^TMP("ACD",$JOB,"VISITS",ACDX))
IF ACDX=""
QUIT
IF ACDX'<ACDDTLOW
IF ACDX'>ACDDTHI
SET ACDY=0
FOR
SET ACDY=$ORDER(^TMP("ACD",$JOB,"VISITS",ACDX,ACDY))
IF 'ACDY
QUIT
Begin DoDot:1
+13 SET ACDQ=0
+14 SET ACDLC=ACDLC+1
+15 SET ACDVLST(ACDLC)=ACDY
+16 SET DIC="9002172.1"
SET DA=ACDY
SET DR=".01;1;3;5"
SET DIQ="ACDPDD("
+17 DO DIQ1^ACDFMC
+18 WRITE ACDLC,?5,ACDPDD(9002172.1,ACDY,.01),?18," - ",ACDPDD(9002172.1,ACDY,1),"/",ACDPDD(9002172.1,ACDY,5)," ",ACDPDD(9002172.1,ACDY,3),!
+19 KILL ACDPDD
+20 IF '(ACDLC#20)
DO PAUSE^ACDDEU
IF $DATA(DIRUT)
SET ACDQ=1
+21 QUIT
End DoDot:1
IF ACDQ
QUIT
+22 SET ACDQ=1
+23 IF 'ACDLC
WRITE !,"No visits in date range",!
QUIT
+24 SET DIR(0)="NO^1:"_ACDLC
SET DIR("A")="Select one of the listed visits"
KILL DA
DO ^DIR
KILL DIR
+25 IF Y
SET ACDVIEN=ACDVLST(Y)
+26 KILL ACDLC,ACDVLST
+27 IF 'ACDVIEN
QUIT
+28 SET ACDQ=0
+29 QUIT
+30 ;
GETDTRNG ; GET DATE RANGE FOR VISIT
+1 SET ACDQ=1
+2 SET ACDDTLOW=$ORDER(^TMP("ACD",$JOB,"VISITS",0))
SET ACDDTHI=$ORDER(^TMP("ACD",$JOB,"VISITS","Z"),-1)
+3 WRITE !,"Patient has ",ACDVCNT," visits between ",$$FMTE^XLFDT(ACDDTLOW,"1")," and ",$$FMTE^XLFDT(ACDDTHI,"1"),".",!,"Enter date range of desired visit.",!
+4 SET DIR(0)="DO^::E"
SET DIR("A")="Enter beginning date"
KILL DA
DO ^DIR
KILL DIR
+5 IF 'Y
QUIT
+6 SET ACDDTLOW=Y
+7 SET DIR(0)="D^"_Y_"::E"
SET DIR("A")="Enter ending date"
SET DIR("B")=X
KILL DA
DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)
QUIT
+9 SET ACDDTHI=Y
+10 SET ACDQ=0
+11 QUIT
+12 ;
DISPLAY ; EP - DISPLAY VISIT AND SUBORDINATE FILE ENTRIES
+1 IF $ORDER(^ACDVIS(ACDVIEN,21,0))
Begin DoDot:1
+2 WRITE !!,"This CDMIS visit has linked PCC visits."
+3 SET DIR(0)="Y"
SET DIR("A")="Do you want to display the PCC visits also"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+4 IF Y
SET ACDPCCL=1
+5 QUIT
End DoDot:1
DISPTAG IF $DATA(IO("Q"))
Begin DoDot:1
+1 SET ZTRTN="DISPLAYQ^ACDPVDSP"
SET ZTDESC="CDMIS VISIT DISPLAY"
SET ZTDTH=$HOROLOG
SET ZTSAVE("ACD*")=""
+2 DO ^%ZTLOAD
+3 QUIT
End DoDot:1
QUIT
+4 DO DISPLAYQ
SET ACDQ=0
+5 QUIT
+6 ;
DISPLAYQ ; EP - FOR TASKMAN
+1 IF $DATA(ACDSLAVE)
SET IOP=ACDSLAVE
DO ^%ZIS
+2 USE IO
+3 IF IO'=IO(0)
WRITE @IOF
+4 IF $EXTRACT(IOST,1,2)="P-"
DO CONF^ACDDEU
+5 WRITE !
+6 DO DSPVSIT^ACDDEU(ACDVIEN)
+7 IF $EXTRACT(IOST,1,2)'="P-"
DO PAUSE^ACDDEU
+8 IF $DATA(DIRUT)
QUIT
+9 SET X=$PIECE(^ACDVIS(ACDVIEN,0),U,4)
+10 IF X'="IN"
IF X'="RE"
IF X'="FU"
IF X'="IR"
IF X'="OT"
IF X'="TD"
IF X'="CS"
WRITE !,"INVALID TYPE CONTACT",!
+11 IF '$TEST
SET ACDCONT=X
DO @("DSP"_ACDCONT)
+12 IF $GET(ACDPCCL)
NEW ACDPCCV
SET ACDPCCL=0
FOR
SET ACDPCCL=$ORDER(^ACDVIS(ACDVIEN,21,ACDPCCL))
IF 'ACDPCCL
QUIT
SET ACDPCCV=$PIECE(^(ACDPCCL,0),U,2)
IF ACDPCCV
SET APCDVDSP=ACDPCCV
DO ^APCDVDSP
IF $DATA(DIRUT)
QUIT
+13 IF $DATA(ACDSLAVE)
WRITE @IOF
DO ^%ZISC
+14 IF $DATA(ZTQUEUED)
DO EOJ
SET ZTREQ="@"
+15 QUIT
+16 ;
DSPIN ; DISPLAY INITIAL
+1 DO DSPIIF
+2 QUIT
+3 ;
DSPRE ; DISPLAY REOPEN
+1 DO DSPIIF
+2 QUIT
+3 ;
DSPFU ; DISPLAY FOLLOWUP
+1 DO DSPIIF
+2 QUIT
+3 ;
DSPIR ; DISPLAY INFO/REFERRAL
+1 DO DSPIIF
+2 QUIT
+3 ;
DSPOT ; DISPLAY CRISIS BRIEF
+1 DO DSPIIF
+2 QUIT
+3 ;
DSPIIF ; DISPLAY IIF ENTRY
+1 SET DIC="^ACDIIF("
SET DA=$ORDER(^ACDIIF("C",ACDVIEN,0))
+2 IF 'DA
WRITE !,"NO IIF ENTRY TO DISPLAY",!
+3 IF '$TEST
DO DIQ^ACDFMC
+4 IF $EXTRACT(IOST,1,2)'="P-"
DO PAUSE^ACDDEU
+5 QUIT
+6 ;
DSPTD ; DISPLAY TDC ENTRY
+1 SET DIC="^ACDTDC("
SET DA=$ORDER(^ACDTDC("C",ACDVIEN,0))
+2 IF 'DA
WRITE !,"NO TDC ENTRY TO DISPLAY",!
+3 IF '$TEST
DO DIQ^ACDFMC
+4 IF $EXTRACT(IOST,1,2)'="P-"
DO PAUSE^ACDDEU
+5 QUIT
+6 ;
DSPCS ; DISPLAY CLIENT SERVICES
+1 SET ACDY=0
+2 SET ACDQ=0
+3 FOR
SET ACDY=$ORDER(^ACDCS("C",ACDVIEN,ACDY))
IF 'ACDY
QUIT
Begin DoDot:1
+4 SET DIC="^ACDCS("
SET DA=ACDY
+5 DO DIQ^ACDFMC
+6 IF $EXTRACT(IOST,1,2)'="P-"
DO PAUSE^ACDDEU
+7 QUIT
End DoDot:1
IF $DATA(DIRUT)
QUIT
+8 SET ACDQ=0
+9 QUIT
+10 ;
EOJ ;
+1 DO ^%ZISC
+2 DO ^ACDKILL
+3 QUIT
