DGPMGLG2 ;ALB/LM - G&L GENERATION, CONT.; 24 MAY 90
;;5.3;Registration;**12,34,418**;Aug 13, 1993
;
;Finds 2 most recent locations and treating specialties for the
;corresponding admission (note that ASIH creates its own admission,
;and its TS's and wards apply to that admit only.)
;
;MV("LWD")= last ward (actually, current ward for this MN)
;MV("PWD")= previous ward (just prior to MV("LWD"))
;MV("LTS")= last TS (actually, current TS for this MN)
;MV("LTS")= previous TS (just prior to MV("LTS"))
;
;Note: ASIH is a special case, as the movement TO ASIH contains the
;first ASIH location and TS, which do not really apply to the NHCU/DOM
;corresponding admission.
;Thus, when returning from ASIH, the corresponding Previous data
;must be found in the movement prior to the move TO ASIH.
;
A D LAST,^DGPMGLG5
Q K X,X3,J,J1,J2
Q
;
LAST S (D,MV("LWD"),MV("PWD"),MV("LTS"),MV("PTS"),MV("ASIH"),ZMV("LWD"),ZMV("LTS"),ATS,PTS)="",(WDC,TSC)=0
;
I "^13^42^43^44^45^47^"'[("^"_+MV("MT")_"^") S:$P(MD,"^",6)]"" MV("LWD")=$P(MD,"^",6) ; Last Ward
I "^13^"[("^"_+MV("MT")_"^") S:$P(MD,"^",6)]"" ZMV("LWD")=$P(MD,"^",6) ; Last Ward
I "^7^"[("^"_+MV("MT")_"^") S:$P(AD,"^",6)]"" MV("LWD")=$P(AD,"^",6) ; Last Ward
; check for corres. movement for location, If admit, Quit
I +MV("MT")=20,$P(MD,"^",24)]"",$D(^DGPM(+$P(MD,"^",24),0)) S:$P(^(0),"^",6)]"" MV("LWD")=$P(^(0),"^",6) I +MV("TT")=6,$P(^DGPM($P(MD,"^",24),0),"^",2)=1 Q
I "^13^42^43^44^45^47^"'[("^"_+MV("MT")_"^") S:$P(MD,"^",9)]"" MV("LTS")=$P(MD,"^",9) ; Last TS
I "^13^"[("^"_+MV("MT")_"^"),$P(MD,"^",15)]"" S X=$O(^DGPM("ATS",DFN,$P(MD,"^",15),0)) I X D ; looks for ASIH admisssion
.S ZMV("LTS")=$O(^DGPM("ATS",DFN,$P(MD,"^",15),X,0)) ; Last TS
I ZMV("LTS")]"" S ZMV("LTS")=ZMV("LTS")_"^"_$S('$D(^DIC(45.7,+ZMV("LTS"),0)):"NO TS",$P(^(0),"^",3)]"":$P(^(0),"^",3),$P(^(0),"^")]"":$E($P(^(0),"^"),1,5),1:"NO TS") ; Last TS
;
S J=9999999.9999999-(MD+($P(MD,"^",22)/10000000))
F S J=$O(^DGPM("APMV",DFN,MV("CA"),J)) Q:'J!(D) D
.I MV("MT")=14,MV("LWD"),'MV("PWD") D ASIHR^DGPMGLG4 Q ;checks if return from ASIH
.I MV("LWD"),MV("MT")=20,$F("^13^43^44^45^",U_$P(MDP,"^",18)_U),'MV("PWD") D ASIHR^DGPMGLG4 Q ;return from ASIH, TS change
.S J2=$O(^DGPM("APMV",DFN,MV("CA"),J,0)) Q:'J2!(D) I $D(^DGPM(J2,0)) S X=^(0) D LAST1
;
PREV S:MV("PWD")="" MV("PWD")=MV("LWD")
I MV("MT")=13 S:$P(MDP,"^",6)]"" MV("PWD")=$P(MDP,"^",6) S:$P(MDP,"^",9)]"" MV("PTS")=$P(MDP,"^",9)
I MV("TT")=3&($P(MDP,"^",18)=4) S:$P(MDP,"^",6)]"" MV("PWD")=$P(MDP,"^",6) S:$P(MDP,"^",9)]"" MV("PTS")=$P(MDP,"^",9)
S MV("PWD")=MV("PWD")_"^"_$S($D(^DIC(42,+MV("PWD"),0)):$E($P(^(0),"^",1),1,7),1:"NO WARD") ; Previous Ward
S MV("LWD")=MV("LWD")_"^"_$S($D(^DIC(42,+MV("LWD"),0)):$E($P(^(0),"^",1),1,7),1:"NO WARD") ; Last Ward
I +MV("PWD")'=+MV("LWD") S WDC=1 ; Ward Change
;
TSC ;looks for most recent, or corresponding TS if one was associated with
;the movement
S X=$O(^DGPM("ATS",DFN,MV("CA"),9999999.999999-MD))
S ATS=$O(^DGPM("ATS",DFN,MV("CA"),+X,0)) ; ATS=Associated TS
I 9999999.9999999-MD=X D ; If the TS is a corresponding one, look for one previous.
.S X3=$O(^DGPM("ATS",DFN,MV("CA"),+X)) I X3 S PTS=$O(^(X3,0)) ; PTS=Previous TS
;
S:MV("LTS")="" MV("LTS")=ATS
I MV("PTS")="" S MV("PTS")=$S(PTS]"":PTS,1:MV("LTS")) I PTS="" S E("PT")="" I MV("TT")=6 S TSC=1
S MV("PTS")=MV("PTS")_"^"_$S('$D(^DIC(45.7,+MV("PTS"),0)):"NO TS",$P(^(0),"^",3)]"":$P(^(0),"^",3),$P(^(0),"^")]"":$E($P(^(0),"^"),1,5),1:"NO TS") ; Previous TS
S MV("LTS")=MV("LTS")_"^"_$S('$D(^DIC(45.7,+MV("LTS"),0)):"NO TS",$P(^(0),"^",3)]"":$P(^(0),"^",3),$P(^(0),"^")]"":$E($P(^(0),"^"),1,5),1:"NO TS") ; Last TS
I +MV("PTS")'=+MV("LTS") S TSC=1 ; TS Change
D TSDIV^DGPMGLG4 ; retrieves associated divisions for TS's.
Q
;
LAST1 ; Ward location
; Service (NH or Dom) check
I $P(X,"^",6)]"" S D1=0 F II="LWD","PWD" Q:D1 I MV(II)="" S MV(II)=$P(X,"^",6),D1=1 I "^42^43^44^45^47^"[("^"_+MV("MT")_"^") S X1=$S($D(^DIC(42,+MV(II),0)):$P(^(0),"^",3),1:"") D ;p-418
.I "^NH^D^"'[("^"_X1_"^")&($P(^(0),"^",17)'=1) S MV(II)="",D1=0 ;p-418 added second condition for IMLTC wards
;
; Facility TS
I $P(X,"^",9)]"" S D1=0 F II="LTS","PTS" Q:D1 I MV(II)="" S MV(II)=$P(X,"^",9),D1=1
S D1=0 F II="LTS","PTS","LWD","PWD" I MV(II)]"" S D1=D1+1
S:D1=4 D=1 K D1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMGLG2 4398 printed Dec 13, 2024@02:49:39 Page 2
DGPMGLG2 ;ALB/LM - G&L GENERATION, CONT.; 24 MAY 90
+1 ;;5.3;Registration;**12,34,418**;Aug 13, 1993
+2 ;
+3 ;Finds 2 most recent locations and treating specialties for the
+4 ;corresponding admission (note that ASIH creates its own admission,
+5 ;and its TS's and wards apply to that admit only.)
+6 ;
+7 ;MV("LWD")= last ward (actually, current ward for this MN)
+8 ;MV("PWD")= previous ward (just prior to MV("LWD"))
+9 ;MV("LTS")= last TS (actually, current TS for this MN)
+10 ;MV("LTS")= previous TS (just prior to MV("LTS"))
+11 ;
+12 ;Note: ASIH is a special case, as the movement TO ASIH contains the
+13 ;first ASIH location and TS, which do not really apply to the NHCU/DOM
+14 ;corresponding admission.
+15 ;Thus, when returning from ASIH, the corresponding Previous data
+16 ;must be found in the movement prior to the move TO ASIH.
+17 ;
A DO LAST
DO ^DGPMGLG5
Q KILL X,X3,J,J1,J2
+1 QUIT
+2 ;
LAST SET (D,MV("LWD"),MV("PWD"),MV("LTS"),MV("PTS"),MV("ASIH"),ZMV("LWD"),ZMV("LTS"),ATS,PTS)=""
SET (WDC,TSC)=0
+1 ;
+2 ; Last Ward
IF "^13^42^43^44^45^47^"'[("^"_+MV("MT")_"^")
if $PIECE(MD,"^",6)]""
SET MV("LWD")=$PIECE(MD,"^",6)
+3 ; Last Ward
IF "^13^"[("^"_+MV("MT")_"^")
if $PIECE(MD,"^",6)]""
SET ZMV("LWD")=$PIECE(MD,"^",6)
+4 ; Last Ward
IF "^7^"[("^"_+MV("MT")_"^")
if $PIECE(AD,"^",6)]""
SET MV("LWD")=$PIECE(AD,"^",6)
+5 ; check for corres. movement for location, If admit, Quit
+6 IF +MV("MT")=20
IF $PIECE(MD,"^",24)]""
IF $DATA(^DGPM(+$PIECE(MD,"^",24),0))
if $PIECE(^(0),"^",6)]""
SET MV("LWD")=$PIECE(^(0),"^",6)
IF +MV("TT")=6
IF $PIECE(^DGPM($PIECE(MD,"^",24),0),"^",2)=1
QUIT
+7 ; Last TS
IF "^13^42^43^44^45^47^"'[("^"_+MV("MT")_"^")
if $PIECE(MD,"^",9)]""
SET MV("LTS")=$PIECE(MD,"^",9)
+8 ; looks for ASIH admisssion
IF "^13^"[("^"_+MV("MT")_"^")
IF $PIECE(MD,"^",15)]""
SET X=$ORDER(^DGPM("ATS",DFN,$PIECE(MD,"^",15),0))
IF X
Begin DoDot:1
+9 ; Last TS
SET ZMV("LTS")=$ORDER(^DGPM("ATS",DFN,$PIECE(MD,"^",15),X,0))
End DoDot:1
+10 ; Last TS
IF ZMV("LTS")]""
SET ZMV("LTS")=ZMV("LTS")_"^"_$SELECT('$DATA(^DIC(45.7,+ZMV("LTS"),0)):"NO TS",$PIECE(^(0),"^",3)]"":$PIECE(^(0),"^",3),$PIECE(^(0),"^")]"":$EXTRACT($PIECE(^(0),"^"),1,5),1:"NO TS")
+11 ;
+12 SET J=9999999.9999999-(MD+($PIECE(MD,"^",22)/10000000))
+13 FOR
SET J=$ORDER(^DGPM("APMV",DFN,MV("CA"),J))
if 'J!(D)
QUIT
Begin DoDot:1
+14 ;checks if return from ASIH
IF MV("MT")=14
IF MV("LWD")
IF 'MV("PWD")
DO ASIHR^DGPMGLG4
QUIT
+15 ;return from ASIH, TS change
IF MV("LWD")
IF MV("MT")=20
IF $FIND("^13^43^44^45^",U_$PIECE(MDP,"^",18)_U)
IF 'MV("PWD")
DO ASIHR^DGPMGLG4
QUIT
+16 SET J2=$ORDER(^DGPM("APMV",DFN,MV("CA"),J,0))
if 'J2!(D)
QUIT
IF $DATA(^DGPM(J2,0))
SET X=^(0)
DO LAST1
End DoDot:1
+17 ;
PREV if MV("PWD")=""
SET MV("PWD")=MV("LWD")
+1 IF MV("MT")=13
if $PIECE(MDP,"^",6)]""
SET MV("PWD")=$PIECE(MDP,"^",6)
if $PIECE(MDP,"^",9)]""
SET MV("PTS")=$PIECE(MDP,"^",9)
+2 IF MV("TT")=3&($PIECE(MDP,"^",18)=4)
if $PIECE(MDP,"^",6)]""
SET MV("PWD")=$PIECE(MDP,"^",6)
if $PIECE(MDP,"^",9)]""
SET MV("PTS")=$PIECE(MDP,"^",9)
+3 ; Previous Ward
SET MV("PWD")=MV("PWD")_"^"_$SELECT($DATA(^DIC(42,+MV("PWD"),0)):$EXTRACT($PIECE(^(0),"^",1),1,7),1:"NO WARD")
+4 ; Last Ward
SET MV("LWD")=MV("LWD")_"^"_$SELECT($DATA(^DIC(42,+MV("LWD"),0)):$EXTRACT($PIECE(^(0),"^",1),1,7),1:"NO WARD")
+5 ; Ward Change
IF +MV("PWD")'=+MV("LWD")
SET WDC=1
+6 ;
TSC ;looks for most recent, or corresponding TS if one was associated with
+1 ;the movement
+2 SET X=$ORDER(^DGPM("ATS",DFN,MV("CA"),9999999.999999-MD))
+3 ; ATS=Associated TS
SET ATS=$ORDER(^DGPM("ATS",DFN,MV("CA"),+X,0))
+4 ; If the TS is a corresponding one, look for one previous.
IF 9999999.9999999-MD=X
Begin DoDot:1
+5 ; PTS=Previous TS
SET X3=$ORDER(^DGPM("ATS",DFN,MV("CA"),+X))
IF X3
SET PTS=$ORDER(^(X3,0))
End DoDot:1
+6 ;
+7 if MV("LTS")=""
SET MV("LTS")=ATS
+8 IF MV("PTS")=""
SET MV("PTS")=$SELECT(PTS]"":PTS,1:MV("LTS"))
IF PTS=""
SET E("PT")=""
IF MV("TT")=6
SET TSC=1
+9 ; Previous TS
SET MV("PTS")=MV("PTS")_"^"_$SELECT('$DATA(^DIC(45.7,+MV("PTS"),0)):"NO TS",$PIECE(^(0),"^",3)]"":$PIECE(^(0),"^",3),$PIECE(^(0),"^")]"":$EXTRACT($PIECE(^(0),"^"),1,5),1:"NO TS")
+10 ; Last TS
SET MV("LTS")=MV("LTS")_"^"_$SELECT('$DATA(^DIC(45.7,+MV("LTS"),0)):"NO TS",$PIECE(^(0),"^",3)]"":$PIECE(^(0),"^",3),$PIECE(^(0),"^")]"":$EXTRACT($PIECE(^(0),"^"),1,5),1:"NO TS")
+11 ; TS Change
IF +MV("PTS")'=+MV("LTS")
SET TSC=1
+12 ; retrieves associated divisions for TS's.
DO TSDIV^DGPMGLG4
+13 QUIT
+14 ;
LAST1 ; Ward location
+1 ; Service (NH or Dom) check
+2 ;p-418
IF $PIECE(X,"^",6)]""
SET D1=0
FOR II="LWD","PWD"
if D1
QUIT
IF MV(II)=""
SET MV(II)=$PIECE(X,"^",6)
SET D1=1
IF "^42^43^44^45^47^"[("^"_+MV("MT")_"^")
SET X1=$SELECT($DATA(^DIC(42,+MV(II),0)):$PIECE(^(0),"^",3),1:"")
Begin DoDot:1
+3 ;p-418 added second condition for IMLTC wards
IF "^NH^D^"'[("^"_X1_"^")&($PIECE(^(0),"^",17)'=1)
SET MV(II)=""
SET D1=0
End DoDot:1
+4 ;
+5 ; Facility TS
+6 IF $PIECE(X,"^",9)]""
SET D1=0
FOR II="LTS","PTS"
if D1
QUIT
IF MV(II)=""
SET MV(II)=$PIECE(X,"^",9)
SET D1=1
+7 SET D1=0
FOR II="LTS","PTS","LWD","PWD"
IF MV(II)]""
SET D1=D1+1
+8 if D1=4
SET D=1
KILL D1
+9 QUIT
