ACDPSOT ;IHS/ADC/EDE/KML - DISPLAY IN/RE/TD/FU OVER TIME;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
;
; This routine displays a patient's CDMIS INITIAL, REOPEN,
; TRANS/DISCH/CLOSE, and FOLLOWUP visits with subordinate file entry
; to use to track status over time.
;
START ;
F D PATLOOP Q:ACDQ
D EOJ
Q
;
PATLOOP ; DISPLAY PATIENTS UNTIL DONE
D GETPAT
Q:ACDQ
D RESTRICT ; see if restrictions apply
Q:ACDQ
D DISPLAY ; write face sheet
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
;
RESTRICT ; SEE IF RESTRICTIONS APPLY
S (ACDCOMC,ACDCOMT)=""
S DIR(0)="YO",DIR("A")="Do you wish to restrict the output to one Component code/type",DIR("B")="N" K DA D ^DIR K DIR
D:Y GETCOMP^ACDDE2
Q
;
DISPLAY ;
W !
D DEV^ACDDEU
Q:POP
I $D(IO("Q")) D Q
. S ZTRTN="DISPLAYQ^ACDPSOT",ZTDESC="CDMIS FACE SHEET",ZTDTH=$H,ZTSAVE("ACD*")=""
. D ^%ZTLOAD
. Q
D DISPLAYQ
U 0
Q
;
DISPLAYQ ; EP - FOR TASKMAN
I $D(ACDSLAVE) S IOP=ACDSLAVE D ^%ZIS
U IO
I '$D(ACDSLAVE) W @IOF
D GETVSITS^ACDDEU ; gather all visits for patient
I $O(^TMP("ACD",$J,"VISITS",0))="" W !,"----------",!,"No CDMIS visits!",!,"----------",! Q
S (ACDX,ACDY)=0
F Q:ACDQ 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 Q:ACDQ
. S ACDQ=0
. I ACDCOMC]"",ACDCOMT]"" D
.. S X=$P(^ACDVIS(ACDY,0),U,2)
.. I X'=ACDCOMC S ACDQ=1 Q
.. S X=$P(^ACDVIS(ACDY,0),U,7)
.. I X'=ACDCOMT S ACDQ=1 Q
.. Q
. I ACDQ S ACDQ=0 Q
. S ACDTC=$P(^ACDVIS(ACDY,0),U,4)
. Q:ACDTC'="IN"&(ACDTC'="RE")&(ACDTC'="TD")&(ACDTC'="FU")
. S ACDVIEN=ACDY
. NEW ACDX,ACDY,ACDCOMC,ACDCOMT
. D DISPLAY2
. Q
I $D(ACDSLAVE) D ^%ZISC
I $D(ZTQUEUED) D EOJ S ZTREQ="@"
Q
;
DISPLAY2 ; WRITE ONE FACE SHEET
U IO
D:$E(IOST,1,2)="P-" CONF^ACDDEU
S ACDDA=ACDVIEN,ACDWSTAF(1)=1 D ^ACDWVIS K ACDWSTAF
S ACDTC=$P(^ACDVIS(ACDVIEN,0),U,4)
I ACDTC="TD" S ACDDA=$O(^ACDTDC("C",ACDVIEN,0)) I 1
E S ACDDA=$O(^ACDIIF("C",ACDVIEN,0))
Q:'ACDDA
D @("^ACDW"_$S(ACDTC="TD":"TDC",1:"IIF"))
S ACDPFACE=1
D P1^ACDWCD1
K ACDPFACE
I '$D(ZTQUEUED),'$D(ACDSLAVE),$E(IOST,1,2)'="P-" D PAUSE^ACDDEU S:$D(DIRUT) ACDQ=1
W:$D(IOF) @IOF
Q
;
EOJ ;
D ^%ZISC
D ^ACDKILL
Q
ACDPSOT ;IHS/ADC/EDE/KML - DISPLAY IN/RE/TD/FU OVER TIME;
+1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
+2 ;
+3 ; This routine displays a patient's CDMIS INITIAL, REOPEN,
+4 ; TRANS/DISCH/CLOSE, and FOLLOWUP visits with subordinate file entry
+5 ; to use to track status over time.
+6 ;
START ;
+1 FOR
DO PATLOOP
IF ACDQ
QUIT
+2 DO EOJ
+3 QUIT
+4 ;
PATLOOP ; DISPLAY PATIENTS UNTIL DONE
+1 DO GETPAT
+2 IF ACDQ
QUIT
+3 ; see if restrictions apply
DO RESTRICT
+4 IF ACDQ
QUIT
+5 ; write face sheet
DO DISPLAY
+6 QUIT
+7 ;
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 ;
RESTRICT ; SEE IF RESTRICTIONS APPLY
+1 SET (ACDCOMC,ACDCOMT)=""
+2 SET DIR(0)="YO"
SET DIR("A")="Do you wish to restrict the output to one Component code/type"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+3 IF Y
DO GETCOMP^ACDDE2
+4 QUIT
+5 ;
DISPLAY ;
+1 WRITE !
+2 DO DEV^ACDDEU
+3 IF POP
QUIT
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTRTN="DISPLAYQ^ACDPSOT"
SET ZTDESC="CDMIS FACE SHEET"
SET ZTDTH=$HOROLOG
SET ZTSAVE("ACD*")=""
+6 DO ^%ZTLOAD
+7 QUIT
End DoDot:1
QUIT
+8 DO DISPLAYQ
+9 USE 0
+10 QUIT
+11 ;
DISPLAYQ ; EP - FOR TASKMAN
+1 IF $DATA(ACDSLAVE)
SET IOP=ACDSLAVE
DO ^%ZIS
+2 USE IO
+3 IF '$DATA(ACDSLAVE)
WRITE @IOF
+4 ; gather all visits for patient
DO GETVSITS^ACDDEU
+5 IF $ORDER(^TMP("ACD",$JOB,"VISITS",0))=""
WRITE !,"----------",!,"No CDMIS visits!",!,"----------",!
QUIT
+6 SET (ACDX,ACDY)=0
+7 FOR
IF ACDQ
QUIT
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
Begin DoDot:1
+8 SET ACDQ=0
+9 IF ACDCOMC]""
IF ACDCOMT]""
Begin DoDot:2
+10 SET X=$PIECE(^ACDVIS(ACDY,0),U,2)
+11 IF X'=ACDCOMC
SET ACDQ=1
QUIT
+12 SET X=$PIECE(^ACDVIS(ACDY,0),U,7)
+13 IF X'=ACDCOMT
SET ACDQ=1
QUIT
+14 QUIT
End DoDot:2
+15 IF ACDQ
SET ACDQ=0
QUIT
+16 SET ACDTC=$PIECE(^ACDVIS(ACDY,0),U,4)
+17 IF ACDTC'="IN"&(ACDTC'="RE")&(ACDTC'="TD")&(ACDTC'="FU")
QUIT
+18 SET ACDVIEN=ACDY
+19 NEW ACDX,ACDY,ACDCOMC,ACDCOMT
+20 DO DISPLAY2
+21 QUIT
End DoDot:1
IF ACDQ
QUIT
+22 IF $DATA(ACDSLAVE)
DO ^%ZISC
+23 IF $DATA(ZTQUEUED)
DO EOJ
SET ZTREQ="@"
+24 QUIT
+25 ;
DISPLAY2 ; WRITE ONE FACE SHEET
+1 USE IO
+2 IF $EXTRACT(IOST,1,2)="P-"
DO CONF^ACDDEU
+3 SET ACDDA=ACDVIEN
SET ACDWSTAF(1)=1
DO ^ACDWVIS
KILL ACDWSTAF
+4 SET ACDTC=$PIECE(^ACDVIS(ACDVIEN,0),U,4)
+5 IF ACDTC="TD"
SET ACDDA=$ORDER(^ACDTDC("C",ACDVIEN,0))
IF 1
+6 IF '$TEST
SET ACDDA=$ORDER(^ACDIIF("C",ACDVIEN,0))
+7 IF 'ACDDA
QUIT
+8 DO @("^ACDW"_$SELECT(ACDTC="TD":"TDC",1:"IIF"))
+9 SET ACDPFACE=1
+10 DO P1^ACDWCD1
+11 KILL ACDPFACE
+12 IF '$DATA(ZTQUEUED)
IF '$DATA(ACDSLAVE)
IF $EXTRACT(IOST,1,2)'="P-"
DO PAUSE^ACDDEU
IF $DATA(DIRUT)
SET ACDQ=1
+13 IF $DATA(IOF)
WRITE @IOF
+14 QUIT
+15 ;
EOJ ;
+1 DO ^%ZISC
+2 DO ^ACDKILL
+3 QUIT
