source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGODNP1.m@ 1397

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