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

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.4 KB
Line 
1DGODNP1 ;ALB/EG - OUTPUT TOT DISCH BY MEANS TEST CAT ; 23 DEC 88@0957
2 ;;5.3;Registration;;Aug 13, 1993
3 ;;V 4.5
4 S DGJB=2,U="^",ZRT=0,%DT="T",X="N" D ^%DT S (DGGE,T2)=Y X ^DD("DD") S T2=Y
5 I (DG05[",")&(($D(DGBD)=0)!($D(DGND)=0)) Q
6 W !,"INPATIENT DISCHARGES BY MEANS TEST CATEGORY",!
7 W !,"REPORT REQUIRES 132 COLUMN OUTPUT",!
8 D:DG05'["," BG Q:($D(DGBD)=0)!($D(DGND)=0)
9DDV S %ZIS="NQ",%ZIS("A")="QUEUE ON DEVICE: " D ^%ZIS G:POP END
10 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
11 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
12 S %DT("A")="Requested Start Time: ",%DT="FATE",%DT(0)="NOW",%DT("B")="NOW" D ^%DT K %DT(0) G:Y<0 END
13 S DGQDT=Y D TRN^DGODASK F I=1:1:DGSP D QTSK
14 Q
15EN 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
16 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
17 S DGJB=2,DGTN=1 D ^DGODNP2 D:DGMO=1 ^DGODCV
18END D:'POP ^%ZISC I IO'=IO(0) U IO(0)
19 K ^UTILITY("DGOD",$J,2),^("AI"),^("T1"),^("TOT"),^("T")
20 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
21 K DGX,H1,H2,I,J,K,K1,PTF,T2,X,Y,ZRT,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
22 Q
23QTSK ;queue task
24 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
25 D ^%ZTLOAD
26 Q
27BG S U="^",POP=0,%DT="APE",%DT(0)=-DT,%DT("A")="From DATE: " D ^%DT G:Y'>0 END
28 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
29 Q
30 ;
310 F I=1:1 S B1=$O(^DGPT("ADS",B1)) Q:(B1="")!(B1>(DGND+.9999)) D 1
32 Q
331 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
34 Q
352 S DFN=$P(^DGPT(B2,0),U,1) Q:$D(^DPT(DFN,.36))=0
36 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
37 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
38 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
39 ;
40ZRO ;zero facility+suffix
41 S A2=A2+1 S A(A2)=U_DGDV D G1^DGODUTL S ^UTILITY("DGOD",$J,"AI",A2)=U_DGDV Q
42 ;
43DIV ;get facility for cases where PTF has div as ""
44 S DGDV=$P(^DGPT(B2,0),U,3)_$P(^(0),U,5) Q:DGDV'=""
45 S DFN=$P(^DGPT(B2,0),U,1),DGWADM=$O(^DGPM("AMV3",B1,DFN,0)) Q:DGWADM=""
46 S DGWARD=$P(^DGPM(DGWADM,0),"^",6) I DGWARD="" S DGDV="" Q
47 S DGDV=$P(^DIC(42,DGWARD,0),U,11) Q:DGDV="" S DGDV=$P(^DG(40.8,DGDV,0),U,2)
48 Q
49 ;
50MT ;if MT="U" drive variation of DGPTF3 to determine current MT
51 S PTF=B2,AD=$P(^DGPT(B2,0),U,2) D ^DGODMT S DGMT=$S(DGX'="":DGX,1:"U")
52 Q
Note: See TracBrowser for help on using the repository browser.