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

Last change on this file was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.8 KB
Line 
1DGPASS ;ALB/JDS - ABSENCE LIST ; 01 JAN 86 @0800
2 ;;5.3;Registration;**162**;Aug 13, 1993
3 ;
4EN D QUIT S %DT="AEPT",%DT("A")="Enter date of Absence: " D ^%DT G:Y'>0 QUIT G EN:+Y>(DT+1) S DGT=+Y,DG2=DGT,DGT=$S(DGT[".":DGT,1:DGT_".2400"),DG2=DGT
5 S DGVAR="DGT^DG2",DGPGM="START^DGPASS" D ZIS^DGUTQ I 'POP U IO D START^DGPASS
6QUIT D CLOSE^DGUTQ G QUIT1^DGOASIH
7START D NOW^%DTC S Y=$E(%,1,12) S DGTIME=$$FMTE^XLFDT(Y,1) S $P(DGCL,"-",81)=""
8 S X1=DGT,X2=-32 D C^%DTC S DGSTART=X
9 S Y=DGT\1 X ^DD("DD") S DGDAY=Y
10 S DGFL=0 D EEN I '$D(^UTILITY($J,"DG")) W !!?8,"*** THERE ARE NO PATIENTS OUT ON ABSENCE FOR "_DGDAY_" ***" G QUIT
11 D WR G QUIT
12 ;
13EEN S DGA="^25^26^43^44^45^13^1^2^3^" D NOW^%DTC S DGNOW=%
14 S DGDAT=DGT
15 F DGDT=DGSTART:0 S DGDT=$O(^DGPM("AMV2",DGDT)) Q:'DGDT!(DGDT>DGDAT) F DFN=0:0 S DFN=$O(^DGPM("AMV2",DGDT,DFN)) Q:'DFN F DGIFN=0:0 S DGIFN=$O(^DGPM("AMV2",DGDT,DFN,DGIFN)) Q:'DGIFN D CK
16 Q
17CK ;check to see if xfr to absence
18 Q:'$D(^DGPM(+DGIFN,0)) S DGX=^(0),DGCA=$P(DGX,"^",14)
19 Q:'$D(^DGPM(+DGCA,0))
20 I DGA'[("^"_$P(DGX,"^",18)_"^") Q ;not mvt to absence
21 S DGFL=0 ;DGFL=1 if patient returned from absence
22 S DGFL=0 F DGI=DGDT+.0000005:0 S DGI=$O(^DGPM("APCA",DFN,DGCA,DGI)) Q:'DGI!(DGI>DGDAT) S DGJ=$O(^DGPM("APCA",DFN,DGCA,+DGI,0)) I $D(^DGPM(+DGJ,0)) S DGY=^(0) D OUT
23 I 'DGFL D SET
24 Q
25SET S VAIP("D")=DGDAT D IN5^VADPT S:VAIP(1)']"" DGFL=1 Q:VAIP(1)']"" S DGADM=VAIP(1) I $D(^DGPM(DGADM,0)) S $P(DGX,"^",5)=$P(^DGPM(DGADM,0),"^",5),$P(DGX,"^",6)=$P(^DGPM(DGADM,0),"^",6),$P(DGX,"^",13)=$P(^DGPM(DGADM,0),"^",13)
26 Q:$P(^DGPM(DGADM,0),"^",6)']"" S DGDV=$P(^DIC(42,+$P(^DGPM(DGADM,0),"^",6),0),"^",11) S DGDV=$S(DGDV]"":$P(^DG(40.8,DGDV,0),"^"),1:"ZUNKNOWN"),DGP=$P(^DPT(DFN,0),"^",1)
27 D PID^VADPT6
28 S DGTYP=$P(DGX,"^",18),DGTP=$S(DGTYP=1:"PASS",DGTYP=2!(DGTYP=26):"AA",DGTYP=3!(DGTYP=25):"UA",DGTYP=13!(DGTYP=43)!(DGTYP=44)!(DGTYP=45):"ASIH",1:""),DGCD=0,X=+DGX\1 D:X]"" DAT S:DGCD DGLV=DGCD
29 I "^25^26^"[("^"_+VAIP(4)_"^") S DGTP=$S(+VAIP(4)=25:"UA",1:"AA")
30 S DGCD=0 S X=$S($P(DGX,"^",13):$P(DGX,"^",13),1:"") D:X]"" DAT S DGRT=$S(DGCD:DGCD,1:"")
31 S DGW=$S($P(DGX,"^",5)]""&($P(DGX,"^",5)'?.N):$P(DGX,"^",5),$P(DGX,"^",5)]""&($P(DGX,"^",5)?.N):$P(^DIC(4,$P(DGX,"^",5),0),"^",1),1:$P(^DIC(42,$P(DGX,"^",6),0),"^"))
32 I DGFL Q ;already returned...don't store
33 I $D(DGDFN(DFN)) Q ;patient already stored once
34 I $D(DGASIH) S DGDFN(DFN)=DFN,^UTILITY($J,"DG",DGDV,DGP,DFN)=VA("PID")_"^"_DGLV_"^"_DGW Q
35 S DGDFN(DFN)=DFN,^UTILITY($J,"DG",DGDV,DGP,DFN)=VA("PID")_"^"_DGTP_"^"_DGLV_"^"_DGRT_"^"_DGW S (VA("PID"),DGTP,DGLV,DGRT,DGW)=""
36 Q
37 ;
38OUT ;check to see if patient returned from absence - DGFL=1 if yes
39 S DGTYP=$P(DGY,"^",18)
40 I $P(DGY,"^",2)=3,(DGTYP'=42),+DGY<DGDAT S DGFL=1 Q
41 I $P(DGY,"^",2)=3,(DGTYP'=41),+DGY<DGDAT S DGFL=1 Q
42 I "^14^22^23^24^"[("^"_DGTYP_"^"),+DGY<DGDAT S DGFL=1 Q
43 I DGNOW<+DGY Q ;future movement...ignore
44 I DGTYP=42,+DGY<DGDAT S DGFL=1 Q ;if WHILE ASIH and not future...
45 Q
46DAT S DGCD=$E(X,4,5)_"-"_$E(X,6,7)_"-"_(1700+$E(X,1,3)) Q
47HEAD S DGPG=DGPG+1 W @IOF,!,"ABSENCE LIST FOR ",DGDAY,?40,"PRINTED: ",DGTIME,?72," PAGE: "_DGPG
48 W !!,"NAME",?22,"PT ID",?36,"TYPE",?42,"LEAVE",?54,"RETURN",?66,"WARD"
49 W !,DGCL,!!,?10,"DIVISION: ",$S(DGDV="ZUNKNOWN":"UNKNOWN",1:DGDV),!
50 Q
51WR S (DGU,DGDV,DGFL,DGP)=0
52 F DGD=0:0 S DGDV=$O(^UTILITY($J,"DG",DGDV)) Q:DGDV=""!(DGU) S DGPG=0 D:DGFL RT Q:DGU D HEAD F M=0:0 S DGP=$O(^UTILITY($J,"DG",DGDV,DGP)) Q:DGP=""!(DGU) D WRCNT
53 W ! Q
54WRCNT F DFN=0:0 S DFN=$O(^UTILITY($J,"DG",DGDV,DGP,DFN)) Q:'DFN!(DGU) S DGNO=^UTILITY($J,"DG",DGDV,DGP,DFN) D WR1 S DGFL=1
55 Q
56WR1 I $Y+4>IOSL D:IOST?1"C-".E RT Q:DGU D HEAD
57 W !,$E(DGP,1,20),?22,$P(DGNO,"^"),?36,$P(DGNO,"^",2),?42,$P(DGNO,"^",3),?54,$P(DGNO,"^",4),?66,$E($P(DGNO,"^",5),1,14) Q
58RT Q:IOST'?1"C-".E
59 F X=$Y:1:(IOSL-2) W !
60 R !?22,"Enter <RET> to continue or ^ to Quit",X:DTIME S:X["^"!('$T) DGU=1 Q:DGU=1
Note: See TracBrowser for help on using the repository browser.