DGPMGLG5 ;ALB/LM - G&L GENERATION, CONT.; 27 APR 2003
;;5.3;Registration;**34,137,515,570**;Aug 13, 1993
;
A ;
S NLS=0 ; non-loss indicator
I MV("TT")=2!(MV("TT")=3) D NLS ; MV("TT")=2 (transfer) MV("TT")=3 (disch)
I MV("TT")=1!(MV("TT")=3)!(MV("TT")=6) D ID ; MV("TT")=1 (adm) MV("TT")=6 (TS transfer)
;
Q Q
;
NLS ; Non-Loss
S X=$P(MDP,"^",18) ; type of movement
I "^1^2^3^25^26^"[("^"_X_"^") S NLS=+X ; NLS=1 (PASS), NLS=2 (AA), NLS=3 (UA), NLS=25 (FROM AA TO UA), NLS=26 (FROM UA TO AA)
S:MV("MT")=42 NLS=42 ; WHILE ASIH
S:MV("MT")=47 NLS=47 ; DISCHARGE FROM NHCU/DOM WHILE ASIH
Q
;
ID ; ID info for patient and legend LEG(X) setup
; Q:MV("TT")'=1!(MV("TT")'=3) ; 1=adm, 3=disch
; Means Test
;I MT,$D(^DG(41.3,DFN,0)) S X=9999999.999998-TO S X=+$O(^DG(41.3,DFN,2,X)) I $D(^(X,0)) S X=$P(^(0),"^",2) I "^A^B^C^R^"[("^"_X_"^") S X=$C($A(X)+32),ID=ID_X,LEG(X)="" K X
I MT,$D(^DGMT(408.31,"C",DFN)) N DGX,X D
. S DGX=$$MTIENLT^DGMTU3(1,DFN,-TO)
. I $D(^DGMT(408.31,+DGX,0)) D
. . S X=$P(^(0),"^",3),X=$P(^DG(408.32,+X,0),"^",2)
. . I $G(X)="P" D ;evaluate pending adjudication to MT (C) or GMT (G)
. . . I '$D(DGX) S X="U" Q
. . . S X=$$PA^DGMTUTL(DGX),X=$S('$D(X):"U",X="MT":"C",X="GMT":"G",1:"U")
. . I "^A^B^C^G^R^"[("^"_X_"^") S X=$C($A(X)+32),ID=ID_X,LEG(X)="" K X,DGX
INS ; Reimburse Insurance (+)
S INS=0
N DGINS,DGX
; API returns ONLY Active and Re-imbursable Insurance entries
I $$INSUR^IBBAPI(DFN,"","",.DGINS,9) D
. S DGX=0 F S DGX=$O(DGINS("IBBAPI","INSUR",DGX)) Q:'DGX S INS=INS+1
S:INS>0 ID=ID_"+",LEG("+")=""
K INS,INS1,JJ
Q:MV("TT")'=3
; While ASIH (*), Discharge after less than 48 hours (#)
I $D(^DGPM(+MV("CA"),0)) S X=^(0) S:$P(X,"^",15) ID=ID_"*",LEG("*")="" S X1=+X,X2=2 D C^%DTC I +MD'>X S ID=ID_"#",LEG("#")="" K X,X1,X2
; Absence (!)
I MDP]"",$P(MDP,"^",2)=2 S X=$P(MDP,"^",18) I "^1^2^3^25^26^"[("^"_X_"^") S ID=ID_"!",LEG("!")="" K X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMGLG5 1957 printed Nov 22, 2024@17:59:43 Page 2
DGPMGLG5 ;ALB/LM - G&L GENERATION, CONT.; 27 APR 2003
+1 ;;5.3;Registration;**34,137,515,570**;Aug 13, 1993
+2 ;
A ;
+1 ; non-loss indicator
SET NLS=0
+2 ; MV("TT")=2 (transfer) MV("TT")=3 (disch)
IF MV("TT")=2!(MV("TT")=3)
DO NLS
+3 ; MV("TT")=1 (adm) MV("TT")=6 (TS transfer)
IF MV("TT")=1!(MV("TT")=3)!(MV("TT")=6)
DO ID
+4 ;
Q QUIT
+1 ;
NLS ; Non-Loss
+1 ; type of movement
SET X=$PIECE(MDP,"^",18)
+2 ; NLS=1 (PASS), NLS=2 (AA), NLS=3 (UA), NLS=25 (FROM AA TO UA), NLS=26 (FROM UA TO AA)
IF "^1^2^3^25^26^"[("^"_X_"^")
SET NLS=+X
+3 ; WHILE ASIH
if MV("MT")=42
SET NLS=42
+4 ; DISCHARGE FROM NHCU/DOM WHILE ASIH
if MV("MT")=47
SET NLS=47
+5 QUIT
+6 ;
ID ; ID info for patient and legend LEG(X) setup
+1 ; Q:MV("TT")'=1!(MV("TT")'=3) ; 1=adm, 3=disch
+2 ; Means Test
+3 ;I MT,$D(^DG(41.3,DFN,0)) S X=9999999.999998-TO S X=+$O(^DG(41.3,DFN,2,X)) I $D(^(X,0)) S X=$P(^(0),"^",2) I "^A^B^C^R^"[("^"_X_"^") S X=$C($A(X)+32),ID=ID_X,LEG(X)="" K X
+4 IF MT
IF $DATA(^DGMT(408.31,"C",DFN))
NEW DGX,X
Begin DoDot:1
+5 SET DGX=$$MTIENLT^DGMTU3(1,DFN,-TO)
+6 IF $DATA(^DGMT(408.31,+DGX,0))
Begin DoDot:2
+7 SET X=$PIECE(^(0),"^",3)
SET X=$PIECE(^DG(408.32,+X,0),"^",2)
+8 ;evaluate pending adjudication to MT (C) or GMT (G)
IF $GET(X)="P"
Begin DoDot:3
+9 IF '$DATA(DGX)
SET X="U"
QUIT
+10 SET X=$$PA^DGMTUTL(DGX)
SET X=$SELECT('$DATA(X):"U",X="MT":"C",X="GMT":"G",1:"U")
End DoDot:3
+11 IF "^A^B^C^G^R^"[("^"_X_"^")
SET X=$CHAR($ASCII(X)+32)
SET ID=ID_X
SET LEG(X)=""
KILL X,DGX
End DoDot:2
End DoDot:1
INS ; Reimburse Insurance (+)
+1 SET INS=0
+2 NEW DGINS,DGX
+3 ; API returns ONLY Active and Re-imbursable Insurance entries
+4 IF $$INSUR^IBBAPI(DFN,"","",.DGINS,9)
Begin DoDot:1
+5 SET DGX=0
FOR
SET DGX=$ORDER(DGINS("IBBAPI","INSUR",DGX))
if 'DGX
QUIT
SET INS=INS+1
End DoDot:1
+6 if INS>0
SET ID=ID_"+"
SET LEG("+")=""
+7 KILL INS,INS1,JJ
+8 if MV("TT")'=3
QUIT
+9 ; While ASIH (*), Discharge after less than 48 hours (#)
+10 IF $DATA(^DGPM(+MV("CA"),0))
SET X=^(0)
if $PIECE(X,"^",15)
SET ID=ID_"*"
SET LEG("*")=""
SET X1=+X
SET X2=2
DO C^%DTC
IF +MD'>X
SET ID=ID_"#"
SET LEG("#")=""
KILL X,X1,X2
+11 ; Absence (!)
+12 IF MDP]""
IF $PIECE(MDP,"^",2)=2
SET X=$PIECE(MDP,"^",18)
IF "^1^2^3^25^26^"[("^"_X_"^")
SET ID=ID_"!"
SET LEG("!")=""
KILL X
+13 QUIT
