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

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

initial load of WorldVistAEHR

File size: 3.7 KB
Line 
1DGPMGLG3 ;ALB/LM - G&L GENERATION, CONT.; 24 MAY 90
2 ;;5.3;Registration;;Aug 13, 1993
3 ;
4A Q:'GL
5 I +MV("MT")=20,$P(MD,"^",24)]"" I $D(^DGPM(+$P(MD,"^",24),0)) I +MV("TT")=6,$P(^DGPM($P(MD,"^",24),0),"^",2)=1 Q
6 I MV("MT")=4,+MV("LWD")=+MV("PWD") Q ; Interward transfer & Last Ward equals Previous Ward
7 S LN=$E(" ",1,5-$L(ID))_ID_" "_$E(MV("NM")_" ",1,18)_" "_$E(MV("SS")_" ",1,$S(SS=1:10,1:5))_" "
8 ;
9 ; If not interward transfer
10 S:+MV("MT")'=4&(+MV("MT")'=13)&(+MV("MT")'=14)&(+MV("MT")'=46) X=$P(MV("LWD"),"^",2),X=$S('TS:$E(X_" ",1,8),1:$E(X_" ["_$P(MV("LTS"),"^",2)_"] ",1,15))
11 ;
12 ; If interward transfer
134 S:+MV("MT")=4 X=$P(MV("PWD"),"^",2),X=$S('TS:X,1:X_" ["_$S('TSC:$P(MV("LTS"),"^",2),1:$P(MV("PTS"),"^",2))_"]")
14 S:+MV("MT")=4 X1=$P(MV("LWD"),"^",2),X1=$S('TS:X1,1:X1_" ["_$P(MV("LTS"),"^",2)_"]"),X=$E(X_"-"_X1_" ",1,31)
15 ;
1613 S:+MV("MT")=13 X=$P(MV("PWD"),"^",2),X=$S('TS:X,1:X_" ["_$S('TSC:$P(MV("LTS"),"^",2),1:$P(MV("PTS"),"^",2))_"]")
17 S:+MV("MT")=13 X1=$S($D(^DIC(42,+ZMV("LWD"),0)):$E($P(^(0),"^",1),1,7),1:""),X1=$S('TS:X1,1:X1_" ["_$S(+ZMV("LTS"):$P(ZMV("LTS"),"^",2),1:$P(MV("LTS"),"^",2))_"]"),X=$E(X_"-"_X1_" ",1,31)
18 ;
1914 I +MV("MT")=14 N D0 S D0=+$O(^DGPM("APID",DFN,9999999.9999998-$P(MD,"^"),0)) D WARD^DGPMUTL ; X=ward at discharge
20 I +MV("MT")=46 S X=$P(MV("PWD"),"^",2),X=$S('TS:X,1:X_" ["_$S('TSC:$P(MV("LTS"),"^",2),1:$P(MV("PTS"),"^",2))_"]")
21 S:+MV("MT")=14 X1=$P(MV("LWD"),"^",2),X1=$S('TS:X1,1:X1_" ["_$P(MV("LTS"),"^",2)_"]"),X=$E(X_"-"_X1_" ",1,31)
22 ;
23 S:+MV("MT")=4 PWDIV=$S($D(^DIC(42,+MV("PWD"),0)):$P(^(0),"^",11),1:0),LWDIV=$S($D(^DIC(42,+MV("LWD"),0)):$P(^(0),"^",11),1:0)
24 ;
25LN S BL="",$P(BL," ",125)=""
26 S LN=$E(LN_X_BL,1,$S(CP=2:63,MV("MT")=4:63,1:40))
27 ;
28 ; Absence Return Date
29 I MV("MT")>0,MV("MT")<4 S Y=$P(MD,"^",13) X:Y]"" ^DD("DD") S:Y]"" Y=$P(Y,",")_","_$E($P(Y,",",2),3,4) S LN=$E(LN,1,47)_"[Ret: "_$S(Y]"":Y,1:"UNKNOWN")_"]"_"^"_$S(SS=1:1,TS:1,1:2)
30 ;
31 ; Transfer Facility
32 S:+MV("MT")=4 LN=LN_"^"_2
33 I "^6^9^10^43^45^46^"[("^"_MV("MT")_"^") S:$P(MD,"^",5) LN=$E(LN,1,47)_$S(MV("MT")=9:"FR",1:"TO")_": "_$S($D(^DIC(4,+$P(MD,"^",5),0)):$P(^(0),"^",1),1:"UNKNOWN") S LN=$E(LN,1,64)_"^"_1
34 I "^14^44^"[("^"_MV("MT")_"^") S:$P(MDP,"^",5) LN=$E(LN,1,47)_"FM: "_$S($D(^DIC(4,+$P(MDP,"^",5),0)):$P(^(0),"^",1),1:"UNKNOWN") S LN=$E(LN,1,64)_"^"_1
35 ;
36NLS ; Non-Loss
37 I NLS'=0 I NLS'=1 I MV("TT")'=1 I MV("TT")'=2 I MV("MT")'=46 S MV("TT")=9999
38 I MV("TT")=2 I NLS>47 S MV("TT")=9999
39 I NLS=2!(NLS=3) S LN=$E(LN,1,47)_"[From "_$S(NLS=2:"",1:"UN")_"AA"_")^"_$S(SS=1:1,1:2)
40 I NLS'=0 I NLS'=1 I MV("TT")'=1,MV("TT")'=2,'SNM,+MV("MT")'=42,+MV("MT")'=47 Q ; If Non-Loss, and NOT Show Non-Movement, and Movement Type is not ASIH then Quit
41 ;
42S1 ; Sets G&L Utility globals
43 S X=$S($D(^DIC(42,+MV("LWD"),0)):^(0),1:"")
44 S DGDIV=+$P(X,"^",11),X=$P(X,"^",3),DGDIV6=$S($D(^DG(40.8,DGDIV,0)):+$P(^(0),"^",6),1:0),DGSRV=$S('DGDIV6:1,X="NH":2,X="D":3,1:1)
45 S ^UTILITY("DGG",$J,DGDIV,DGSRV,MV("TT"),MV("FM"),MV("NM"),DFN_$S($D(MD):$P(MD,"^"),1:0))=LN
46 S ^(MV("TT"))=$S($D(^UTILITY("DGT",$J,DGDIV,DGSRV,MV("TT"))):^(MV("TT")),1:0)+1
47 S ^(MV("FM"))=$S($D(^UTILITY("DGF",$J,DGDIV,DGSRV,MV("TT"),MV("FM"))):^(MV("FM")),1:0)+1
48 I +MV("MT")'=4 G Q
49 I PWDIV=LWDIV G Q
50 S X=$S($D(^DIC(42,+MV("PWD"),0)):^(0),1:"")
51 S DGDIV=+$P(X,"^",11),X=$P(X,"^",3),DGDIV6=$S($D(^DG(40.8,DGDIV,0)):+$P(^(0),"^",6),1:0),DGSRV=$S('DGDIV6:1,X="NH":2,X="D":3,1:1)
52 S ^UTILITY("DGG",$J,DGDIV,DGSRV,MV("TT"),MV("FM"),MV("NM"),DFN_$S($D(MD):$P(MD,"^"),1:0))=LN
53 S ^(MV("TT"))=$S($D(^UTILITY("DGT",$J,DGDIV,DGSRV,MV("TT"))):^(MV("TT")),1:0)+1
54 S ^(MV("FM"))=$S($D(^UTILITY("DGF",$J,DGDIV,DGSRV,MV("TT"),MV("FM"))):^(MV("FM")),1:0)+1
55Q K DGDIV,DGDIV6,DGSRV,PWDIV,LWDIV,ZMV("LTS"),ZMV("LWD"),MV("OD")
56 Q
Note: See TracBrowser for help on using the repository browser.