DGPMGLG3.m

DGPMGLG3 ;ALB/LM - G&L GENERATION, CONT.; 24 MAY 90

 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21

 ;

A Q:'GL

 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

 I MV("MT")=4,+MV("LWD")=+MV("PWD") Q  ;  Interward transfer & Last Ward equals Previous Ward

 S LN=$E("     ",1,5-$L(ID))_ID_" "_$E(MV("NM")_"                  ",1,18)_" "_$E(MV("SS")_"         ",1,$S(SS=1:10,1:5))_" "

 ;

 ;  If not interward transfer

 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))

 ;

 ;  If interward transfer

4 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))_"]")

 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)

 ;

13 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))_"]")

 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)

 ;

14 I +MV("MT")=14 N D0 S D0=+$O(^DGPM("APID",DFN,9999999.9999998-$P(MD,"^"),0)) D WARD^DGPMUTL ; X=ward at discharge

 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))_"]")

 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)

 ;

 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)

 ;

LN S BL="",$P(BL," ",125)=""

 S LN=$E(LN_X_BL,1,$S(CP=2:63,MV("MT")=4:63,1:40))

 ;

 ;  Absence Return Date

 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)

 ;

 ;  Transfer Facility

 S:+MV("MT")=4 LN=LN_"^"_2

 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

 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

 ;

NLS ;  Non-Loss

 I NLS'=0 I NLS'=1 I MV("TT")'=1 I MV("TT")'=2 I MV("MT")'=46 S MV("TT")=9999

 I MV("TT")=2 I NLS>47 S MV("TT")=9999

 I NLS=2!(NLS=3) S LN=$E(LN,1,47)_"[From "_$S(NLS=2:"",1:"UN")_"AA"_")^"_$S(SS=1:1,1:2)

 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

 ;

S1 ;  Sets G&L Utility globals

 S X=$S($D(^DIC(42,+MV("LWD"),0)):^(0),1:"")

 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)

 S ^UTILITY("DGG",$J,DGDIV,DGSRV,MV("TT"),MV("FM"),MV("NM"),DFN_$S($D(MD):$P(MD,"^"),1:0))=LN

 S ^(MV("TT"))=$S($D(^UTILITY("DGT",$J,DGDIV,DGSRV,MV("TT"))):^(MV("TT")),1:0)+1

 S ^(MV("FM"))=$S($D(^UTILITY("DGF",$J,DGDIV,DGSRV,MV("TT"),MV("FM"))):^(MV("FM")),1:0)+1

 I +MV("MT")'=4 G Q

 I PWDIV=LWDIV G Q

 S X=$S($D(^DIC(42,+MV("PWD"),0)):^(0),1:"")

 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)

 S ^UTILITY("DGG",$J,DGDIV,DGSRV,MV("TT"),MV("FM"),MV("NM"),DFN_$S($D(MD):$P(MD,"^"),1:0))=LN

 S ^(MV("TT"))=$S($D(^UTILITY("DGT",$J,DGDIV,DGSRV,MV("TT"))):^(MV("TT")),1:0)+1

 S ^(MV("FM"))=$S($D(^UTILITY("DGF",$J,DGDIV,DGSRV,MV("TT"),MV("FM"))):^(MV("FM")),1:0)+1

Q K DGDIV,DGDIV6,DGSRV,PWDIV,LWDIV,ZMV("LTS"),ZMV("LWD"),MV("OD")

 Q

DGPMGLG3  ;ALB/LM - G&L GENERATION, CONT.; 24 MAY 90

 +1       ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21

 +2       ;

A          IF 'GL

               QUIT 

 +1        IF +MV("MT")=20

               IF $PIECE(MD,"^",24)]""

                   IF $DATA(^DGPM(+$PIECE(MD,"^",24),0))

                       IF +MV("TT")=6

                           IF $PIECE(^DGPM($PIECE(MD,"^",24),0),"^",2)=1

                               QUIT 

 +2       ;  Interward transfer & Last Ward equals Previous Ward

           IF MV("MT")=4

               IF +MV("LWD")=+MV("PWD")

                   QUIT 

 +3        SET LN=$EXTRACT("     ",1,5-$LENGTH(ID))_ID_" "_$EXTRACT(MV("NM")_"                  ",1,18)_" "_$EXTRACT(MV("SS")_"         ",1,$SELECT(SS=1:10,1:5))_" "

 +4       ;

 +5       ;  If not interward transfer

 +6        IF +MV("MT")'=4&(+MV("MT")'=13)&(+MV("MT")'=14)&(+MV("MT")'=46)

               SET X=$PIECE(MV("LWD"),"^",2)

               SET X=$SELECT('TS:$EXTRACT(X_"       ",1,8),1:$EXTRACT(X_" ["_$PIECE(MV("LTS"),"^",2)_"]            ",1,15))

 +7       ;

 +8       ;  If interward transfer

4          IF +MV("MT")=4

               SET X=$PIECE(MV("PWD"),"^",2)

               SET X=$SELECT('TS:X,1:X_" ["_$SELECT('TSC:$PIECE(MV("LTS"),"^",2),1:$PIECE(MV("PTS"),"^",2))_"]")

 +1        IF +MV("MT")=4

               SET X1=$PIECE(MV("LWD"),"^",2)

               SET X1=$SELECT('TS:X1,1:X1_" ["_$PIECE(MV("LTS"),"^",2)_"]")

               SET X=$EXTRACT(X_"-"_X1_"                    ",1,31)

 +2       ;

13         IF +MV("MT")=13

               SET X=$PIECE(MV("PWD"),"^",2)

               SET X=$SELECT('TS:X,1:X_" ["_$SELECT('TSC:$PIECE(MV("LTS"),"^",2),1:$PIECE(MV("PTS"),"^",2))_"]")

 +1        IF +MV("MT")=13

               SET X1=$SELECT($DATA(^DIC(42,+ZMV("LWD"),0)):$EXTRACT($PIECE(^(0),"^",1),1,7),1:"")

               SET X1=$SELECT('TS:X1,1:X1_" ["_$SELECT(+ZMV("LTS"):$PIECE(ZMV("LTS"),"^",2),1:$PIECE(MV("LTS"),"^",2))_"]")

               SET X=$EXTRACT(X_"-"_X1_"                    ",1,31)

 +2       ;

14        ; X=ward at discharge

           IF +MV("MT")=14

               NEW D0

               SET D0=+$ORDER(^DGPM("APID",DFN,9999999.9999998-$PIECE(MD,"^"),0))

               DO WARD^DGPMUTL

 +1        IF +MV("MT")=46

               SET X=$PIECE(MV("PWD"),"^",2)

               SET X=$SELECT('TS:X,1:X_" ["_$SELECT('TSC:$PIECE(MV("LTS"),"^",2),1:$PIECE(MV("PTS"),"^",2))_"]")

 +2        IF +MV("MT")=14

               SET X1=$PIECE(MV("LWD"),"^",2)

               SET X1=$SELECT('TS:X1,1:X1_" ["_$PIECE(MV("LTS"),"^",2)_"]")

               SET X=$EXTRACT(X_"-"_X1_"                    ",1,31)

 +3       ;

 +4        IF +MV("MT")=4

               SET PWDIV=$SELECT($DATA(^DIC(42,+MV("PWD"),0)):$PIECE(^(0),"^",11),1:0)

               SET LWDIV=$SELECT($DATA(^DIC(42,+MV("LWD"),0)):$PIECE(^(0),"^",11),1:0)

 +5       ;

LN         SET BL=""

           SET $PIECE(BL," ",125)=""

 +1        SET LN=$EXTRACT(LN_X_BL,1,$SELECT(CP=2:63,MV("MT")=4:63,1:40))

 +2       ;

 +3       ;  Absence Return Date

 +4        IF MV("MT")>0

               IF MV("MT")<4

                   SET Y=$PIECE(MD,"^",13)

                   IF Y]""

                       XECUTE ^DD("DD")

                   IF Y]""

                       SET Y=$PIECE(Y,",")_","_$EXTRACT($PIECE(Y,",",2),3,4)

                   SET LN=$EXTRACT(LN,1,47)_"[Ret: "_$SELECT(Y]"":Y,1:"UNKNOWN")_"]"_"^"_$SELECT(SS=1:1,TS:1,1:2)

 +5       ;

 +6       ;  Transfer Facility

 +7        IF +MV("MT")=4

               SET LN=LN_"^"_2

 +8        IF "^6^9^10^43^45^46^"[("^"_MV("MT")_"^")

               IF $PIECE(MD,"^",5)

                   SET LN=$EXTRACT(LN,1,47)_$SELECT(MV("MT")=9:"FR",1:"TO")_": "_$SELECT($DATA(^DIC(4,+$PIECE(MD,"^",5),0)):$PIECE(^(0),"^",1),1:"UNKNOWN")

               SET LN=$EXTRACT(LN,1,64)_"^"_1

 +9        IF "^14^44^"[("^"_MV("MT")_"^")

               IF $PIECE(MDP,"^",5)

                   SET LN=$EXTRACT(LN,1,47)_"FM: "_$SELECT($DATA(^DIC(4,+$PIECE(MDP,"^",5),0)):$PIECE(^(0),"^",1),1:"UNKNOWN")

               SET LN=$EXTRACT(LN,1,64)_"^"_1

 +10      ;

NLS       ;  Non-Loss

 +1        IF NLS'=0

               IF NLS'=1

                   IF MV("TT")'=1

                       IF MV("TT")'=2

                           IF MV("MT")'=46

                               SET MV("TT")=9999

 +2        IF MV("TT")=2

               IF NLS>47

                   SET MV("TT")=9999

 +3        IF NLS=2!(NLS=3)

               SET LN=$EXTRACT(LN,1,47)_"[From "_$SELECT(NLS=2:"",1:"UN")_"AA"_")^"_$SELECT(SS=1:1,1:2)

 +4       ;  If Non-Loss, and NOT Show Non-Movement, and Movement Type is not ASIH then Quit

           IF NLS'=0

               IF NLS'=1

                   IF MV("TT")'=1

                       IF MV("TT")'=2

                           IF 'SNM

                               IF +MV("MT")'=42

                                   IF +MV("MT")'=47

                                       QUIT 

 +5       ;

S1        ;  Sets G&L Utility globals

 +1        SET X=$SELECT($DATA(^DIC(42,+MV("LWD"),0)):^(0),1:"")

 +2        SET DGDIV=+$PIECE(X,"^",11)

           SET X=$PIECE(X,"^",3)

           SET DGDIV6=$SELECT($DATA(^DG(40.8,DGDIV,0)):+$PIECE(^(0),"^",6),1:0)

           SET DGSRV=$SELECT('DGDIV6:1,X="NH":2,X="D":3,1:1)

 +3        SET ^UTILITY("DGG",$JOB,DGDIV,DGSRV,MV("TT"),MV("FM"),MV("NM"),DFN_$SELECT($DATA(MD):$PIECE(MD,"^"),1:0))=LN

 +4        SET ^(MV("TT"))=$SELECT($DATA(^UTILITY("DGT",$JOB,DGDIV,DGSRV,MV("TT"))):^(MV("TT")),1:0)+1

 +5        SET ^(MV("FM"))=$SELECT($DATA(^UTILITY("DGF",$JOB,DGDIV,DGSRV,MV("TT"),MV("FM"))):^(MV("FM")),1:0)+1

 +6        IF +MV("MT")'=4

               GOTO Q

 +7        IF PWDIV=LWDIV

               GOTO Q

 +8        SET X=$SELECT($DATA(^DIC(42,+MV("PWD"),0)):^(0),1:"")

 +9        SET DGDIV=+$PIECE(X,"^",11)

           SET X=$PIECE(X,"^",3)

           SET DGDIV6=$SELECT($DATA(^DG(40.8,DGDIV,0)):+$PIECE(^(0),"^",6),1:0)

           SET DGSRV=$SELECT('DGDIV6:1,X="NH":2,X="D":3,1:1)

 +10       SET ^UTILITY("DGG",$JOB,DGDIV,DGSRV,MV("TT"),MV("FM"),MV("NM"),DFN_$SELECT($DATA(MD):$PIECE(MD,"^"),1:0))=LN

 +11       SET ^(MV("TT"))=$SELECT($DATA(^UTILITY("DGT",$JOB,DGDIV,DGSRV,MV("TT"))):^(MV("TT")),1:0)+1

 +12       SET ^(MV("FM"))=$SELECT($DATA(^UTILITY("DGF",$JOB,DGDIV,DGSRV,MV("TT"),MV("FM"))):^(MV("FM")),1:0)+1

Q          KILL DGDIV,DGDIV6,DGSRV,PWDIV,LWDIV,ZMV("LTS"),ZMV("LWD"),MV("OD")

 +1        QUIT