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 ---[H[J[2J[HDGODNP1 3557 printed Oct 16, 2024@18:47:02 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
