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

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

initial load of WorldVistAEHR

File size: 3.5 KB
Line 
1DGA4001 ;ALB/MRL - LIST PENDING OR OPEN DISPOSITIONS ;01 JAN 1988@2300
2 ;;5.3;Registration;**162**;Aug 13, 1993
3 D UP^DGA400 I IO=DGDEV W !!,"===> Checking for Pending/Open Dispositions..."
4 D VAR,H^DGUTL S $P(^DG(43,1,"AMIS"),"^",1)=DGTIME,Y=DGA1 X ^DD("DD") S DGH="PENDING/OPEN DISPOSITIONS, ",X="MONTH OF '"_Y_"'.",DGH=DGH_X,$P(^DG(43,1,"AMIS"),"^",6)=X
5EN2 K ^UTILITY($J) F I=DGA1:0 S I=$O(^DPT("ADIS",I)) Q:'I!(I>DGAE1) F DFN=0:0 S DFN=$O(^DPT("ADIS",I,DFN)) Q:'DFN F I1=0:0 S I1=$O(^DPT("ADIS",I,DFN,I1)) Q:'I1 I $D(^DPT(DFN,"DIS",I1,0)) S DGAD=^(0) D SET
6 F I=0:0 S I=$O(^UTILITY($J,"DGDISP",I)),DGAP="" Q:'I D DV,HD F I1=0:0 S DGAP=$O(^UTILITY($J,"DGDISP",I,DGAP)) Q:DGAP="" F I2=0:0 S I2=$O(^UTILITY($J,"DGDISP",I,DGAP,I2)) Q:'I2 S X=^(I2) D WR
7Q W !! W:DGO!(DGP) DGL1,!! G QUIT1^DGA4002:DGQUIT
8 D:DGHOME MES I DGO D ^DGA4003 G QUIT^DGA4002
9 D PMES^DGA4003:DGP S DGA=DGA1 K %DT,DFN,DGA1,DGAD,DGAE1,DGAP,DGC,DGDATE,DGTIME,DGDV,DGH,DGHOME,DGL,DGL1,DGO,DGP,DGPGM,DGQUIT G ^DGA4004
10WR I $Y>$S($D(IOSL):(IOSL-4),1:20) W !,DGL1 D HD
11 W !,$E($P(DGAP,",",1)_","_$E(DGAP,$F(DGAP,",")),1,20),?22,$P(X,"^",1)
12 S X1="" I +I2 S X1=$E(I2,1,12),X1=$$FMTE^XLFDT(X1,"5F"),X1=$TR(X1," ","0")
13 W ?29,X1,?50,$P(X,"^",2),?72,$P(X,"^",3) Q
14HD W @IOF,!,DGH,!,"DIVISION: ",$P(DGDV,"^",2) S Y=DT X ^DD("DD") S X1="Date Printed: "_Y W ?(78-$L(X1)),X1,!!,"Patient Name",?22,"PT ID",?29,"Reg. Date/Time",?50,"Application Type",?72,"Status",!,DGL,! Q
15DV I $D(^DG(43,1,"GL")),'$P(^("GL"),"^",2) S DGDV=$S($O(^DG(40.8,0))>0:$O(^DG(40.8,0)),1:"UNKNOWN") I DGDV S DGDV=DGDV_"^"_$P(^DG(40.8,+DGDV,0),"^",1) Q
16 S DGDV=I_"^"_$S($D(^DG(40.8,+I,0)):$P(^(0),"^",1),1:"UNKNOWN") Q
17SET Q:$P(DGAD,U,2)=1&(I>2891000) W:IO=DGDEV "." I $P(DGAD,"^",6),$D(^DIC(37,+$P(DGAD,"^",7),0)),+$P(^(0),"^",9),$P(^(0),"^",9)'=13 D:'DGO SET1 Q
18 S DGAP=$S($D(^DPT(DFN,0)):^(0),1:"") I $P(DGAD,"^",6),$P(DGAD,"^",7)]"" S DGS=" PEND",DGP=DGP+1
19 E S DGS="**OPEN",DGO=DGO+1
20 D PID^VADPT6 S X=$S(VA("BID"):VA("BID"),1:"NONE")_"^"_$S($P(DGAD,"^",3)=1:"Hospital",$P(DGAD,"^",3)=2:"Domiciliary",$P(DGAD,"^",3)=3:"OP Medical",$P(DGAD,"^",3)=4:"OP Dental",$P(DGAD,"^",3)=5:"Nursing Home",1:"Unknown")_"^"_DGS K VA
21 S ^UTILITY($J,"DGDISP",+$P(DGAD,"^",4),$S($P(DGAP,"^",1)]"":$P(DGAP,"^",1),1:"UNKNOWN"),$P(DGAD,"^",1))=X Q:DGO
22SET1 S ^UTILITY($J,"DGDIS",DFN,I1)=DGAD,DGC=DGC+1 Q
23 ;
24EN D VAR S DGDEV=IO,DGQUIT=1,%DT(0)=-DT,%DT="EAX",%DT("A")="Start with REGISTRATION DATE: " D ^%DT G Q:Y'>0 S DGA1=$P(Y,".",1)
25EN1 S %DT(0)=-DT,%DT="EAX",%DT("A")=" Go to REGISTRATION DATE: " D ^%DT G Q:Y'>0 I $S(DGA1=Y:0,Y'>DGA1:1,1:0) W !?4,*7,"MUST BE AFTER START DATE!" G EN1
26 S DGAE1=$P(Y,".",1)_".2359",Y=DGA1 X ^DD("DD") S DGH="PENDING/OPEN DISPOSITIONS FOR '"_Y_"'" I $E(DGA1,1,7)=$E(DGAE1,1,7) S DGH=DGH_"."
27 E S Y=$E(DGAE1,1,7) X ^DD("DD") S DGH=DGH_" THROUGH '"_Y_"'."
28 S X1=DGA1,X2="-1" D C^%DTC S DGA1=X_".2359",DGPGM="EN2^DGA4001",DGVAR="DUZ^DGDEV^DGL^DGL1^DGQUIT^DGA1^DGAE1^DGH^DGO^DGP^DGC" D ZIS^DGUTQ G Q:POP U IO
29 G EN2
30UP D H^DGUTL S $P(^DG(43,1,"AMIS"),"^",2)=DGTIME,$P(^("AMIS"),"^",5)=0 K DGDATE,DGTIME Q
31VAR S:'$D(DTIME) DTIME=300 S:'$D(U) U="^" I '$D(DT) S %DT="",X="T" D ^%DT
32 S (DGO,DGP,DGC,DGL,DGL1)="",$P(DGL,"=",79)="",$P(DGL1,"#",79)="" ;S IOP=$S($D(ION):ION,1:IO) D ^%ZIS K IOP Q
33 Q
34 S (DGO,DGP,DGC,DGL,DGL1)="",$P(DGL,"=",79)="",$P(DGL1,"#",79)="" S IOP=$S($D(ION):ION,1:IO) D ^%ZIS K IOP Q
35MES W !!,"'",+DGP,"' Pending Dispositions on file...",!,"'",+DGO,"' Open Dispositions on file..."
36 I +DGO W !!,"I can't let you generate this report with ""open"" dispositions remaining!",!,"Clear them up and try again later please.",! Q
Note: See TracBrowser for help on using the repository browser.