DGODNP1.m

DGODNP1 ;ALB/EG - OUTPUT TOT DISCH BY MEANS TEST CAT ; 23 DEC 88@0957

 ;;5.3;Registration;;Aug 13, 1993

 ;;V 4.5

 S DGJB=2,U="^",ZRT=0,%DT="T",X="N" D ^%DT S (DGGE,T2)=Y X ^DD("DD") S T2=Y

 I (DG05[",")&(($D(DGBD)=0)!($D(DGND)=0)) Q

 W !,"INPATIENT DISCHARGES BY MEANS TEST CATEGORY",!

 W !,"REPORT REQUIRES 132 COLUMN OUTPUT",!

 D:DG05'["," BG Q:($D(DGBD)=0)!($D(DGND)=0)

DDV S %ZIS="NQ",%ZIS("A")="QUEUE ON DEVICE: " D ^%ZIS G:POP END

 I (IO=IO(0))!(IO=0) W !,"CANNOT QUEUE TO YOUR OWN DEVICE" S %=2 W !,"CONTINUE DIRECTLY TO YOUR I/O DEVICE// " D YN^DICN G:(%=2)!(%<0) END I %=1 S DGMO=0 D EN G END

 I $D(%Y)>0,%Y["?" W !,"If you say YES execution will begin immediately and your default i/o device will hang during compilation, NO or ^ will end" G DDV

 S %DT("A")="Requested Start Time: ",%DT="FATE",%DT(0)="NOW",%DT("B")="NOW" D ^%DT K %DT(0) G:Y<0 END

 S DGQDT=Y D TRN^DGODASK F I=1:1:DGSP D QTSK

 Q

EN K ^UTILITY("DGOD",$J,2) S A2=0,DGREP=$E(DGBD,1,5)_"00",(DGTN,K1)=1,H1=$H,B1=(DGBD-1)+.9999 D LO^DGUTL,0 F I=1:1:A2 S DGDV=$P(A(I),U,2) D T1^DGODUTL

 D TOTW^DGODMT S DGDV=0,H2=$H D ET^DGODUTL F I=0:0 S DGDV=$O(Z(DGDV)) Q:DGDV=""  S ^UTILITY("DGOD",$J,DGJB,DGTN,DGDV)=$C(35)_U_DGGE_U_DGDV_U_DGJB_U_DGBD_U_DGND_U_Z(DGDV)_U_DGTOUT

 S DGJB=2,DGTN=1 D ^DGODNP2 D:DGMO=1 ^DGODCV

END D:'POP ^%ZISC I IO'=IO(0) U IO(0)

 K ^UTILITY("DGOD",$J,2),^("AI"),^("T1"),^("TOT"),^("T")

 K %,DG05,DG0BD,%DT,DG0ND,DG0X,%Y,%ZIS,A,A2,B1,B2,DFN,DGBD,DGDV,DGDVN,DGEL,DGGE,DGJB,DGMO,DGMT,DGND,DGPGM,DGQDT,DGREP,DGSP,DGTN,DGTOUT,DGV,DGVAR,DGWADM,DGWADMT,DGWARD,DGWH

 K DGX,H1,H2,I,J,K,K1,PTF,T2,X,Y,ZRT,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE

 Q

QTSK ;queue task

 S ZTDTH=DGQDT+.0001,DGMO=DGMO(I),DGBD=DG0BD(I),DGND=DG0ND(I),ZTIO=ION_";"_IOM,ZTDESC="DISCRETIONARY WORK REPORT-"_I,ZTRTN="EN^DGODNP1",ZTSAVE("DGJB")=DGJB,ZTSAVE("DGBD")=DGBD,ZTSAVE("DGND")=DGND,ZTSAVE("DGMO")=DGMO,ZTSAVE("DGGE")=DGGE

 D ^%ZTLOAD

 Q

BG S U="^",POP=0,%DT="APE",%DT(0)=-DT,%DT("A")="From DATE: " D ^%DT G:Y'>0 END

 S DGBD=Y,%DT(0)="-TODAY",%DT("A")="To DATE: " D ^%DT G:Y'>0 END S DGND=Y W ! I DGND<DGBD W *7,"TO DATE IS LESS THAN FROM DATE, TRY AGAIN" G BG

 Q

 ;

0 F I=1:1 S B1=$O(^DGPT("ADS",B1)) Q:(B1="")!(B1>(DGND+.9999))  D 1

 Q

1 S B2="" F J=1:1 S B2=$O(^DGPT("ADS",B1,B2)) Q:B2=""  D DIV Q:$L(DGDV)<3  D:$D(^UTILITY("DGOD",$J,DGJB,DGTN,DGDV))=0 ZRO I $D(^DGPT(B2,0))>0,$P(^(0),U,11)<2 D 2

 Q

2 S DFN=$P(^DGPT(B2,0),U,1) Q:$D(^DPT(DFN,.36))=0

 Q:$P(^DPT(DFN,.36),U,1)=""  S DGEL=$P(^(.36),U,1),DGEL=$P(^DIC(8,DGEL,0),U,4),DGWH=$P(^(0),U,5),DGV=$S(DGWH="Y":"V",DGWH="N":"N",1:0) Q:DGV=0

 S DGMT=^DGPT(B2,0) I B1<2860701 S DGMT=$S($P(DGMT,U,10)="*":"U",$P(DGMT,U,10)'="":$P(DGMT,U,10),1:"X") D:DGMT="U" MT S ^UTILITY("DGOD",$J,DGJB,DGTN,DGDV,DGV,DGMT,DGEL)=^UTILITY("DGOD",$J,DGJB,DGTN,DGDV,DGV,DGMT,DGEL)+1 Q

 S DGMT=$S($P(DGMT,U,10)'="":$P(DGMT,U,10),1:"U") D:DGMT="U" MT S ^UTILITY("DGOD",$J,DGJB,DGTN,DGDV,DGV,DGMT,DGEL)=^UTILITY("DGOD",$J,DGJB,DGTN,DGDV,DGV,DGMT,DGEL)+1 Q

 ;

ZRO ;zero facility+suffix

 S A2=A2+1 S A(A2)=U_DGDV D G1^DGODUTL S ^UTILITY("DGOD",$J,"AI",A2)=U_DGDV Q

 ;

DIV ;get facility for cases where PTF has div as ""

 S DGDV=$P(^DGPT(B2,0),U,3)_$P(^(0),U,5) Q:DGDV'=""

 S DFN=$P(^DGPT(B2,0),U,1),DGWADM=$O(^DGPM("AMV3",B1,DFN,0)) Q:DGWADM=""

 S DGWARD=$P(^DGPM(DGWADM,0),"^",6) I DGWARD="" S DGDV="" Q

 S DGDV=$P(^DIC(42,DGWARD,0),U,11) Q:DGDV=""  S DGDV=$P(^DG(40.8,DGDV,0),U,2)

 Q

 ;

MT ;if MT="U" drive variation of DGPTF3 to determine current MT

 S PTF=B2,AD=$P(^DGPT(B2,0),U,2) D ^DGODMT S DGMT=$S(DGX'="":DGX,1:"U")

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DGODNP1   3557     printed  Mar 13, 2025@21:50:58                                                                                                                                                                                                     Page 2

DGODNP1   ;ALB/EG - OUTPUT TOT DISCH BY MEANS TEST CAT ; 23 DEC 88@0957

 +1       ;;5.3;Registration;;Aug 13, 1993

 +2       ;;V 4.5

 +3        SET DGJB=2

           SET U="^"

           SET ZRT=0

           SET %DT="T"

           SET X="N"

           DO ^%DT

           SET (DGGE,T2)=Y

           XECUTE ^DD("DD")

           SET T2=Y

 +4        IF (DG05[",")&(($DATA(DGBD)=0)!($DATA(DGND)=0))

               QUIT 

 +5        WRITE !,"INPATIENT DISCHARGES BY MEANS TEST CATEGORY",!

 +6        WRITE !,"REPORT REQUIRES 132 COLUMN OUTPUT",!

 +7        if DG05'[","

               DO BG

           if ($DATA(DGBD)=0)!($DATA(DGND)=0)

               QUIT 

DDV        SET %ZIS="NQ"

           SET %ZIS("A")="QUEUE ON DEVICE: "

           DO ^%ZIS

           if POP

               GOTO END

 +1        IF (IO=IO(0))!(IO=0)

               WRITE !,"CANNOT QUEUE TO YOUR OWN DEVICE"

               SET %=2

               WRITE !,"CONTINUE DIRECTLY TO YOUR I/O DEVICE// "

               DO YN^DICN

               if (%=2)!(%<0)

                   GOTO END

               IF %=1

                   SET DGMO=0

                   DO EN

                   GOTO END

 +2        IF $DATA(%Y)>0

               IF %Y["?"

                   WRITE !,"If you say YES execution will begin immediately and your default i/o device will hang during compilation, NO or ^ will end"

                   GOTO DDV

 +3        SET %DT("A")="Requested Start Time: "

           SET %DT="FATE"

           SET %DT(0)="NOW"

           SET %DT("B")="NOW"

           DO ^%DT

           KILL %DT(0)

           if Y<0

               GOTO END

 +4        SET DGQDT=Y

           DO TRN^DGODASK

           FOR I=1:1:DGSP

               DO QTSK

 +5        QUIT 

EN         KILL ^UTILITY("DGOD",$JOB,2)

           SET A2=0

           SET DGREP=$EXTRACT(DGBD,1,5)_"00"

           SET (DGTN,K1)=1

           SET H1=$HOROLOG

           SET B1=(DGBD-1)+.9999

           DO LO^DGUTL

           DO 0

           FOR I=1:1:A2

               SET DGDV=$PIECE(A(I),U,2)

               DO T1^DGODUTL

 +1        DO TOTW^DGODMT

           SET DGDV=0

           SET H2=$HOROLOG

           DO ET^DGODUTL

           FOR I=0:0

               SET DGDV=$ORDER(Z(DGDV))

               if DGDV=""

                   QUIT 

               SET ^UTILITY("DGOD",$JOB,DGJB,DGTN,DGDV)=$CHAR(35)_U_DGGE_U_DGDV_U_DGJB_U_DGBD_U_DGND_U_Z(DGDV)_U_DGTOUT

 +2        SET DGJB=2

           SET DGTN=1

           DO ^DGODNP2

           if DGMO=1

               DO ^DGODCV

END        if 'POP

               DO ^%ZISC

           IF IO'=IO(0)

               USE IO(0)

 +1        KILL ^UTILITY("DGOD",$JOB,2),^("AI"),^("T1"),^("TOT"),^("T")

 +2        KILL %,DG05,DG0BD,%DT,DG0ND,DG0X,%Y,%ZIS,A,A2,B1,B2,DFN,DGBD,DGDV,DGDVN,DGEL,DGGE,DGJB,DGMO,DGMT,DGND,DGPGM,DGQDT,DGREP,DGSP,DGTN,DGTOUT,DGV,DGVAR,DGWADM,DGWADMT,DGWARD,DGWH

 +3        KILL DGX,H1,H2,I,J,K,K1,PTF,T2,X,Y,ZRT,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE

 +4        QUIT 

QTSK      ;queue task

 +1        SET ZTDTH=DGQDT+.0001

           SET DGMO=DGMO(I)

           SET DGBD=DG0BD(I)

           SET DGND=DG0ND(I)

           SET ZTIO=ION_";"_IOM

           SET ZTDESC="DISCRETIONARY WORK REPORT-"_I

           SET ZTRTN="EN^DGODNP1"

           SET ZTSAVE("DGJB")=DGJB

           SET ZTSAVE("DGBD")=DGBD

           SET ZTSAVE("DGND")=DGND

           SET ZTSAVE("DGMO")=DGMO

           SET ZTSAVE("DGGE")=DGGE

 +2        DO ^%ZTLOAD

 +3        QUIT 

BG         SET U="^"

           SET POP=0

           SET %DT="APE"

           SET %DT(0)=-DT

           SET %DT("A")="From DATE: "

           DO ^%DT

           if Y'>0

               GOTO END

 +1        SET DGBD=Y

           SET %DT(0)="-TODAY"

           SET %DT("A")="To DATE: "

           DO ^%DT

           if Y'>0

               GOTO END

           SET DGND=Y

           WRITE !

           IF DGND<DGBD

               WRITE *7,"TO DATE IS LESS THAN FROM DATE, TRY AGAIN"

               GOTO BG

 +2        QUIT 

 +3       ;

0          FOR I=1:1

               SET B1=$ORDER(^DGPT("ADS",B1))

               if (B1="")!(B1>(DGND+.9999))

                   QUIT 

               DO 1

 +1        QUIT 

1          SET B2=""

           FOR J=1:1

               SET B2=$ORDER(^DGPT("ADS",B1,B2))

               if B2=""

                   QUIT 

               DO DIV

               if $LENGTH(DGDV)<3

                   QUIT 

               if $DATA(^UTILITY("DGOD",$JOB,DGJB,DGTN,DGDV))=0

                   DO ZRO

               IF $DATA(^DGPT(B2,0))>0

                   IF $PIECE(^(0),U,11)<2

                       DO 2

 +1        QUIT 

2          SET DFN=$PIECE(^DGPT(B2,0),U,1)

           if $DATA(^DPT(DFN,.36))=0

               QUIT 

 +1        if $PIECE(^DPT(DFN,.36),U,1)=""

               QUIT 

           SET DGEL=$PIECE(^(.36),U,1)

           SET DGEL=$PIECE(^DIC(8,DGEL,0),U,4)

           SET DGWH=$PIECE(^(0),U,5)

           SET DGV=$SELECT(DGWH="Y":"V",DGWH="N":"N",1:0)

           if DGV=0

               QUIT 

 +2        SET DGMT=^DGPT(B2,0)

           IF B1<2860701

               SET DGMT=$SELECT($PIECE(DGMT,U,10)="*":"U",$PIECE(DGMT,U,10)'="":$PIECE(DGMT,U,10),1:"X")

               if DGMT="U"

                   DO MT

               SET ^UTILITY("DGOD",$JOB,DGJB,DGTN,DGDV,DGV,DGMT,DGEL)=^UTILITY("DGOD",$JOB,DGJB,DGTN,DGDV,DGV,DGMT,DGEL)+1

               QUIT 

 +3        SET DGMT=$SELECT($PIECE(DGMT,U,10)'="":$PIECE(DGMT,U,10),1:"U")

           if DGMT="U"

               DO MT

           SET ^UTILITY("DGOD",$JOB,DGJB,DGTN,DGDV,DGV,DGMT,DGEL)=^UTILITY("DGOD",$JOB,DGJB,DGTN,DGDV,DGV,DGMT,DGEL)+1

           QUIT 

 +4       ;

ZRO       ;zero facility+suffix

 +1        SET A2=A2+1

           SET A(A2)=U_DGDV

           DO G1^DGODUTL

           SET ^UTILITY("DGOD",$JOB,"AI",A2)=U_DGDV

           QUIT 

 +2       ;

DIV       ;get facility for cases where PTF has div as ""

 +1        SET DGDV=$PIECE(^DGPT(B2,0),U,3)_$PIECE(^(0),U,5)

           if DGDV'=""

               QUIT 

 +2        SET DFN=$PIECE(^DGPT(B2,0),U,1)

           SET DGWADM=$ORDER(^DGPM("AMV3",B1,DFN,0))

           if DGWADM=""

               QUIT 

 +3        SET DGWARD=$PIECE(^DGPM(DGWADM,0),"^",6)

           IF DGWARD=""

               SET DGDV=""

               QUIT 

 +4        SET DGDV=$PIECE(^DIC(42,DGWARD,0),U,11)

           if DGDV=""

               QUIT 

           SET DGDV=$PIECE(^DG(40.8,DGDV,0),U,2)

 +5        QUIT 

 +6       ;

MT        ;if MT="U" drive variation of DGPTF3 to determine current MT

 +1        SET PTF=B2

           SET AD=$PIECE(^DGPT(B2,0),U,2)

           DO ^DGODMT

           SET DGMT=$SELECT(DGX'="":DGX,1:"U")

 +2        QUIT