- DGPMGLG2 ;ALB/LM - G&L GENERATION, CONT.; 24 MAY 90
- ;;5.3;Registration;**12,34,418,1132**;Aug 13, 1993;Build 1
- ;
- ;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=0 D
- .F S X=$O(^DGPM("ATS",DFN,$P(MD,"^",15),X)) Q:'X Q:$G(ZMV("LTS")) D
- ..S DGMVDT=9999999.9999999-X I DGMVDT>TO Q
- ..S ZMV("LTS")=$O(^DGPM("ATS",DFN,$P(MD,"^",15),X,0)) ; Last TS
- ..Q
- .Q
- 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 4472 printed Feb 19, 2025@00:15:41 Page 2
- DGPMGLG2 ;ALB/LM - G&L GENERATION, CONT.; 24 MAY 90
- +1 ;;5.3;Registration;**12,34,418,1132**;Aug 13, 1993;Build 1
- +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 IF "^13^"[("^"_+MV("MT")_"^")
- IF $PIECE(MD,"^",15)]""
- SET X=0
- Begin DoDot:1
- +9 FOR
- SET X=$ORDER(^DGPM("ATS",DFN,$PIECE(MD,"^",15),X))
- if 'X
- QUIT
- if $GET(ZMV("LTS"))
- QUIT
- Begin DoDot:2
- +10 SET DGMVDT=9999999.9999999-X
- IF DGMVDT>TO
- QUIT
- +11 ; Last TS
- SET ZMV("LTS")=$ORDER(^DGPM("ATS",DFN,$PIECE(MD,"^",15),X,0))
- +12 QUIT
- End DoDot:2
- +13 QUIT
- End DoDot:1
- +14 ; 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")
- +15 ;
- +16 SET J=9999999.9999999-(MD+($PIECE(MD,"^",22)/10000000))
- +17 FOR
- SET J=$ORDER(^DGPM("APMV",DFN,MV("CA"),J))
- if 'J!(D)
- QUIT
- Begin DoDot:1
- +18 ;checks if return from ASIH
- IF MV("MT")=14
- IF MV("LWD")
- IF 'MV("PWD")
- DO ASIHR^DGPMGLG4
- QUIT
- +19 ;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
- +20 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
- +21 ;
- 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
