Routine: ACDPFACE

ACDPFACE ;IHS/ADC/EDE/KML - DISPLAY PATIENT VISIT;

 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998

 ; This routine displays a patient's CDMIS INITIAL, REOPEN, or

 ; TRANS/DISCH/CLOSE visit with subordinate file entry to use as a

 ; face sheet in the chart.

START ;

W !

 F  D PATLOOP Q:ACDQ

 D EOJ

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

 I ACDQ S ACDQ=0 Q

 D DISPLAY ;               display selected visit

 I '$D(ACDSLAVE),$E(IOST,1,2)'="P-" D PAUSE^ACDDEU

 D DEV^ACDDEU Q:ACDQ  ;       select device

 I $D(ACDSLAVE)!(IO'=IO(0)) D DISPLAY

 K ACDSLAVE S IO=IO(0)

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

SELECT ; SELECT A CDMIS INITIAL/REOPEN/TDC VISIT

 S ACDQ=1

W !

 S ACDVIEN=0

 K ACDVLST

 I $O(^TMP("ACD",$J,"VISITS",0))="" W !,"----------",!,"No CDMIS visits!",!,"----------",! Q

 S (ACDLC,ACDX,ACDY)=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

 . S ACDTC=$P(^ACDVIS(ACDY,0),U,4)

 . Q:ACDTC'="IN"&(ACDTC'="RE")&(ACDTC'="TD")

 . 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

. Q

 I 'ACDLC W !,"----------",!,"No type IN, RE, or TD visits!",!,"----------",! 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

DISPLAY ; EP - DISPLAY VISIT AND SUBORDINATE FILE ENTRY

 ;//^ACDDE3

 I $D(IO("Q")) D  Q

 . S ZTRTN="DISPLAYQ^ACDPFACE",ZTDESC="CDMIS FACE SHEET",ZTDTH=$H,ZTSAVE("ACD*")=""

 . D ^%ZTLOAD

. Q

 D DISPLAYQ

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

 NEW ACDCOMC,ACDCOMCL,ACDCOMT,ACDCOMTL,ACDCONT,ACDCONTL,ACDDFN,ACDDFNP,ACDPROV,ACDPROVP

 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))

 I 'ACDDA W !!,"No '"_ACDTC_"' attached to this visit.",!

 D @("^ACDW"_$S(ACDTC="TD":"TDC",1:"IIF"))

 S ACDPFACE=1

 D P1^ACDWCD1

 K ACDPFACE

 W:IO'=IO(0) @IOF

 ;I $D(ACDSLAVE) W @IOF D ^%ZISC

 I $D(ACDSLAVE) D ^%ZISC

 I $D(ZTQUEUED) D EOJ S ZTREQ="@"

U 0

EOJ ;

 D ^%ZISC

 D ^ACDKILL

ACDPFACE  ;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 INITIAL, REOPEN, or

 +4       ; TRANS/DISCH/CLOSE visit with subordinate file entry to use as a

 +5       ; face sheet in the chart.

 +6       ;

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

               SET ACDQ=0

               QUIT

 +7       ;               display selected visit

           DO DISPLAY

 +8        IF '$DATA(ACDSLAVE)

               IF $EXTRACT(IOST,1,2)'="P-"

                   DO PAUSE^ACDDEU

 +9       ;       select device

           DO DEV^ACDDEU

           IF ACDQ

               QUIT

 +10       IF $DATA(ACDSLAVE)!(IO'=IO(0))

               DO DISPLAY

 +11       KILL ACDSLAVE

           SET IO=IO(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 INITIAL/REOPEN/TDC 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 (ACDLC,ACDX,ACDY)=0

 +7        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

                   Begin DoDot:1

 +8                    SET ACDTC=$PIECE(^ACDVIS(ACDY,0),U,4)

 +9                    IF ACDTC'="IN"&(ACDTC'="RE")&(ACDTC'="TD")

                           QUIT

 +10                   SET ACDLC=ACDLC+1

 +11                   SET ACDVLST(ACDLC)=ACDY

 +12                   SET DIC="9002172.1"

                       SET DA=ACDY

                       SET DR=".01;1;3;5"

                       SET DIQ="ACDPDD("

 +13                   DO DIQ1^ACDFMC

 +14                   WRITE ACDLC,?5,ACDPDD(9002172.1,ACDY,.01),?18," - ",ACDPDD(9002172.1,ACDY,1),"/",ACDPDD(9002172.1,ACDY,5)," ",ACDPDD(9002172.1,ACDY,3),!

 +15                   KILL ACDPDD

 +16                   QUIT

                   End DoDot:1

 +17       IF 'ACDLC

               WRITE !,"----------",!,"No type IN, RE, or TD visits!",!,"----------",!

               QUIT

 +18       SET DIR(0)="NO^1:"_ACDLC

           SET DIR("A")="Select one of the listed visits"

           KILL DA

           DO ^DIR

           KILL DIR

 +19       IF Y

               SET ACDVIEN=ACDVLST(Y)

 +20       KILL ACDLC,ACDVLST

 +21       IF 'ACDVIEN

               QUIT

 +22       SET ACDQ=0

 +23       QUIT

 +24      ;

DISPLAY   ; EP - DISPLAY VISIT AND SUBORDINATE FILE ENTRY

 +1       ;//^ACDDE3

 +2        IF $DATA(IO("Q"))

               Begin DoDot:1

 +3                SET ZTRTN="DISPLAYQ^ACDPFACE"

                   SET ZTDESC="CDMIS FACE SHEET"

                   SET ZTDTH=$HOROLOG

                   SET ZTSAVE("ACD*")=""

 +4                DO ^%ZTLOAD

 +5                QUIT

               End DoDot:1

               QUIT

 +6        DO DISPLAYQ

 +7        QUIT

 +8       ;

DISPLAYQ  ; EP - FOR TASKMAN

 +1        IF $DATA(ACDSLAVE)

               SET IOP=ACDSLAVE

               DO ^%ZIS

 +2        USE IO

 +3       ;W:IO'=IO(0) @IOF

 +4        IF $EXTRACT(IOST,1,2)="P-"

               DO CONF^ACDDEU

 +5        NEW ACDCOMC,ACDCOMCL,ACDCOMT,ACDCOMTL,ACDCONT,ACDCONTL,ACDDFN,ACDDFNP,ACDPROV,ACDPROVP

 +6        SET ACDDA=ACDVIEN

           SET ACDWSTAF(1)=1

           DO ^ACDWVIS

           KILL ACDWSTAF

 +7        SET ACDTC=$PIECE(^ACDVIS(ACDVIEN,0),U,4)

 +8        IF ACDTC="TD"

               SET ACDDA=$ORDER(^ACDTDC("C",ACDVIEN,0))

               IF 1

 +9       IF '$TEST

               SET ACDDA=$ORDER(^ACDIIF("C",ACDVIEN,0))

 +10       IF 'ACDDA

               WRITE !!,"No '"_ACDTC_"' attached to this visit.",!

 +11       DO @("^ACDW"_$SELECT(ACDTC="TD":"TDC",1:"IIF"))

 +12       SET ACDPFACE=1

 +13       DO P1^ACDWCD1

 +14       KILL ACDPFACE

 +15       IF IO'=IO(0)

               WRITE @IOF

 +16      ;I $D(ACDSLAVE) W @IOF D ^%ZISC

 +17       IF $DATA(ACDSLAVE)

               DO ^%ZISC

 +18       IF $DATA(ZTQUEUED)

               DO EOJ

               SET ZTREQ="@"

 +19       USE 0

 +20       QUIT

 +21      ;

EOJ       ;

 +1        DO ^%ZISC

 +2        DO ^ACDKILL

 +3        QUIT

ACDPFACE.m