- 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
