PSJADT ;BIR/CML3,MLM-AUTO DC/HOLD ON PATIENT ADT ;24 Aug 98 / 2:01 PM
;;5.0;INPATIENT MEDICATIONS ;**3,30,51,50,83,290**;16 DEC 97;Build 16
;
; Reference to ^PS(55 is supported by DBIA# 2191.
; Reference to ^PS(59.7 is supported by DBIA# 2181.
; Reference to ^DIC(42 is supported by DBIA# 1377.
; Reference to ^UTILITY("DGPM" is supported by DBIA# 1181.
;
W:'$D(PSJQUIET)&'$D(DGQUIET) !!,"...Inpatient Medications check..."
N PSJDEL,PSJSYSU,PSJSYSL,PSJSYSP,PSJSYSP0,PSJSYSW,PSJSYSW0,VA200,VAIN,VAIP,X D ENCV^PSGSETU
K PSJADTWD S PSGP=DFN,(PSJCF,PSJAM,PSJDM,PSJTM,PSJTMT,PSJFW)=0,PSJPIND=$G(^PS(55,PSGP,5.1)),VA200=1,(PSJNOO,P("NAT"))="A"
;Added 1 for Admissions that are deleted to the loop in PSJDEL
;Q:$D(PSJQUIET) F PSJDEL=2,3 I $G(^UTILITY("DGPM",$J,PSJDEL,DGPMDA,"P")),'$G(^("A")) D ENDEL^PSJADT1(DFN,DGPMP,$P($G(^UTILITY("DGPM",$J,+PSJDEL,"P")),U,18),PSJDEL) S PSJCF=1 Q
Q:$D(PSJQUIET)
F PSJDEL=1,2,3,6 D
.I $G(^UTILITY("DGPM",$J,PSJDEL,DGPMDA,"P")),'$G(^UTILITY("DGPM",$J,PSJDEL,DGPMDA,"A")) D Q
..D ENDEL^PSJADT1(DFN,DGPMP,$P($G(^UTILITY("DGPM",$J,+PSJDEL,DGPMDA,"P")),U,18),PSJDEL) S PSJCF=1,PSJPIND4=$P(PSJPIND,"^",4) I $G(DGX) D Q
...S:DGX=PSJPIND4 $P(PSJPIND,"^",4)=+DGPM0
D:$G(PSJDEL)=2!$G(PSJDEL)=6 ENUW^PSJADT1 G:PSJCF DONE Q:$D(PSJQUIET)
S Y=3 F Q=0:0 S Q=$O(^UTILITY("DGPM",$J,3,Q)) Q:'Q I $G(^(Q,"A")),$D(^("P")) S PSJDD=^("A") S X=+PSJDD D LC I X S PSJDM=Q,PSJDCA=$P(PSJDD,"^",14),PSJDD=+PSJDD Q
S Y=1 F Q=0:0 S Q=$O(^UTILITY("DGPM",$J,1,Q)) Q:'Q I $G(^(Q,"A")),$D(^("P")),'^("P") S X=+^("A") D LC I X S PSJAM=Q Q
I PSJDM S PSJDF=0 D DIS
I PSJAM D ADM
I PSJCF G DONE
;
TRN ;
S Y=2,Q=0
F S Q=$O(^UTILITY("DGPM",$J,2,Q)) Q:'Q I $G(^(Q,"A")),$D(^("P")),'^("P") S X=+^("A") D LC I X S PSJTM=Q,$P(PSJPIND,"^",4)=+^UTILITY("DGPM",$J,2,Q,"A"),PSJTMT=$P(^UTILITY("DGPM",$J,2,Q,"A"),"^",18) Q
G:'PSJTM DONE I $S('PSJTMT:1,PSJTMT<5:0,PSJTMT>26:1,1:PSJTMT<22) G DONE
K VAIP S VAIP("D")="L" D IN5^VADPT S PSJFW=+VAIP(15,4),PSJPAD=+VAIP(13,1)
;Transfer to authorized or unauthorized absence.
I PSJTMT<4 S PSGOEHA=$P($G(^PS(59.7,1,22,PSJFW,0)),U,PSJTMT+1) G:PSGOEHA'=1&(PSGOEHA'=2) DONE D G DONE
.I PSGOEHA=1 D ENHOLD^PSJADT1(1,PSJTMT,PSJPAD,$S(PSJTMT=3:8580,1:8570)) Q
.S PSGALO=$S(PSJTMT=3:1090,1:1060) D ^PSJADT0
;Return from UA or AA
I PSJTMT>21 G:$P(PSJPIND,"^",7)'=2 DONE D G DONE
.S $P(PSJPIND,"^",7)="",$P(PSJPIND,"^",10)="",PSGALO=$S(PSJTMT=22!(PSJTMT=26):8080,1:8070),PSGOEHA=0 D ENHOLD^PSJADT1(0,$S(PSGALO=8080:3,1:2),PSJPAD,PSGALO)
G:PSJTMT'=4 DONE S PSJADTWD=PSJFW D INP^VADPT I $D(^PS(59.7,1,22,"AFT",PSJFW,+VAIN(4))) S PSGALO=1080 D ENDC^PSJADT0 G DONE
S FS=$S($D(^DIC(42,PSJFW,0)):$P(^(0),"^",3),1:""),TS=$S($D(^DIC(42,+VAIN(4),0)):$P(^(0),"^",3),1:"") I FS]"",TS]"",$D(^PS(59.7,1,23,"AFT",FS,TS)) S PSGALO=1070 D ENDC^PSJADT0 G DONE
D ENUW^PSJADT1
;
DONE ;
I '$D(^PS(55,PSGP,0)) D ENSET0^PSGNE3(PSGP) S $P(^PS(55,PSGP,5.1),"^",11)=2 ; Mark as converted for POE
S ^PS(55,PSGP,5.1)=PSJPIND,PSJNKF=1
K AM,DA,DIE,DIS,DR,FS,ON,ORIFN,PSGAL,PSGALO,PSGALR,PSGOEHA,PSGTOL,PSGTOO,PSGUOW,PSIVLN,PSIVNST,PSIVREA,PSIVRES,PSJADTWD,PSJAM,PSJCF,PSJDA,PSJDD,PSJDCA,PSJDF,PSJDM,PSJFW,PSJIVDCF,PSJIVON,PSJPAD,PSJPDD,PSJPIND,PSJPWD,PSJPWDN
K PSJNOO,P("NAT"),PSJS,PSJTM,PSJTMT,N,P,PS,Q1,Q2,RZ,ST,TS,TSCN,Z D ENKV^PSGSETU W:'$D(PSJQUIET)&'$D(DGQUIET) ".done..." Q
;
DIS ; discharge
K VAIP S VAIP("E")=PSJDCA D IN5^VADPT S PSJPAD=+VAIP(13,1),(PSJADTWD,PSJFW)=+VAIP(17,4),PSGALO=$S(PSJDF:1010,1:1030) D ENDC^PSJADT0 S $P(PSJPIND,"^",8)=1,PSJCF=1
Q
;
ADM ; admit
; ************ old way **************************
;S $P(PSJPIND,"^",3)=+^UTILITY("DGPM",$J,1,PSJAM,"A"),$P(PSJPIND,"^",4)="",$P(PSJPIND,"^",8)="" Q:PSJCF
;S Q=$O(^DGPM("ATID3",DFN,0)) S:Q Q=$O(^(Q,0)) K VAIP S:Q VAIP("E")=Q S:'Q VAIP("D")="LAST" D IN5^VADPT S PSJPAD=+VAIP(13,1),PSJFW=+VAIP(17,4),PSJADTWD=.5 S PSGALO=1050 D ENDC^PSJADT0 S PSJCF=1
; ************ new way **************************
S $P(PSJPIND,"^",3)=+^UTILITY("DGPM",$J,1,PSJAM,"A"),$P(PSJPIND,"^",4)="",$P(PSJPIND,"^",8)="" Q:PSJCF
D IN5^VADPT S VAIP("E")=VAIP(14) S VAIP("D")="LAST" D IN5^VADPT S PSJPAD=+VAIP(13,1),PSJFW=+VAIP(17,4),PSJADTWD=.5 S PSGALO=1050 D ENDC^PSJADT0 S PSJCF=1
Q
;
LC ; is movement the latest one of its type?
;S X=$E(9999999.9999999-X,1,14),Z=$E($O(^DGPM("ATID"_Y,PSGP,0)),1,14) I Z,X>Z S X=0
; *****************************************************************
; ** NEW WAY **
N PSJRSB S PSJRSB("Y")=Y,PSJRSB("X")=X
N VAIP S:Y=3 VAIP("D")="L" D IN5^VADPT S Z=+VAIP(3)
S X=PSJRSB("X") ; set X again, may have changed during ^VADPT
I Z,X<Z S X=0 ; change to x<z because dates are not inverted now
S Y=PSJRSB("Y") ; set Y again, may have changed during ^VADPT
; *****************************************************************
; begin PAL-0402-61286
I Y=3,$S('^UTILITY("DGPM",$J,3,Q,"P"):0,X>($G(PSGDT)):1,$P(PSJDD,"^",18)=$P(^("P"),"^",18):0,$P(PSJDD,"^",18)=12:0,1:$P(PSJDD,"^",18)'=38) S X=0
;I Y=3,$S('^UTILITY("DGPM",$J,3,Q,"P"):0,$P(PSJDD,"^",18)=$P(^("P"),"^",18):0,$P(PSJDD,"^",18)=12:0,1:$P(PSJDD,"^",18)'=38) S X=0
; end PAL-0402-61286
Q
;
END ; he be dead
S DFN=DA N D,DA,DB,DC,DE,DG,DH,DI,DIC,DIE,DIG,DIH,DIK,DIR,DIQ,DIU,DIV,DIW,DK,DL,DM,DP,DR,DQ,DU,DV,DW,D0,D1,D2,MR,NX,VAIN,VAIP
;Naked reference below refers to ^DGPM("ATID1",PSGP,9999999.9999999-X)
; changed to remove ref to ^DGPM
; ** OLD WAY **
;S PSJQUIET=1 D PSJADT S PSJDD=X,PSJDCA=$O(^(+$O(^DGPM("ATID1",PSGP,9999999.9999999-X)),0)),PSJDF=1
; ******************************************************************
; ** NEW WAY **
S PSJQUIET=1 D PSJADT S PSJDD=X N VAIP S VAIP("D")=$P(X,".") D IN5^VADPT
S PSJDCA=$G(VAIP(13)),PSJDF=1
; ******************************************************************
D INP^VADPT,DIS,DONE K PSJQUIET Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJADT 5843 printed Nov 22, 2024@17:16:12 Page 2
PSJADT ;BIR/CML3,MLM-AUTO DC/HOLD ON PATIENT ADT ;24 Aug 98 / 2:01 PM
+1 ;;5.0;INPATIENT MEDICATIONS ;**3,30,51,50,83,290**;16 DEC 97;Build 16
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA# 2191.
+4 ; Reference to ^PS(59.7 is supported by DBIA# 2181.
+5 ; Reference to ^DIC(42 is supported by DBIA# 1377.
+6 ; Reference to ^UTILITY("DGPM" is supported by DBIA# 1181.
+7 ;
+8 if '$DATA(PSJQUIET)&'$DATA(DGQUIET)
WRITE !!,"...Inpatient Medications check..."
+9 NEW PSJDEL,PSJSYSU,PSJSYSL,PSJSYSP,PSJSYSP0,PSJSYSW,PSJSYSW0,VA200,VAIN,VAIP,X
DO ENCV^PSGSETU
+10 KILL PSJADTWD
SET PSGP=DFN
SET (PSJCF,PSJAM,PSJDM,PSJTM,PSJTMT,PSJFW)=0
SET PSJPIND=$GET(^PS(55,PSGP,5.1))
SET VA200=1
SET (PSJNOO,P("NAT"))="A"
+11 ;Added 1 for Admissions that are deleted to the loop in PSJDEL
+12 ;Q:$D(PSJQUIET) F PSJDEL=2,3 I $G(^UTILITY("DGPM",$J,PSJDEL,DGPMDA,"P")),'$G(^("A")) D ENDEL^PSJADT1(DFN,DGPMP,$P($G(^UTILITY("DGPM",$J,+PSJDEL,"P")),U,18),PSJDEL) S PSJCF=1 Q
+13 if $DATA(PSJQUIET)
QUIT
+14 FOR PSJDEL=1,2,3,6
Begin DoDot:1
+15 IF $GET(^UTILITY("DGPM",$JOB,PSJDEL,DGPMDA,"P"))
IF '$GET(^UTILITY("DGPM",$JOB,PSJDEL,DGPMDA,"A"))
Begin DoDot:2
+16 DO ENDEL^PSJADT1(DFN,DGPMP,$PIECE($GET(^UTILITY("DGPM",$JOB,+PSJDEL,DGPMDA,"P")),U,18),PSJDEL)
SET PSJCF=1
SET PSJPIND4=$PIECE(PSJPIND,"^",4)
IF $GET(DGX)
Begin DoDot:3
+17 if DGX=PSJPIND4
SET $PIECE(PSJPIND,"^",4)=+DGPM0
End DoDot:3
QUIT
End DoDot:2
QUIT
End DoDot:1
+18 if $GET(PSJDEL)=2!$GET(PSJDEL)=6
DO ENUW^PSJADT1
if PSJCF
GOTO DONE
if $DATA(PSJQUIET)
QUIT
+19 SET Y=3
FOR Q=0:0
SET Q=$ORDER(^UTILITY("DGPM",$JOB,3,Q))
if 'Q
QUIT
IF $GET(^(Q,"A"))
IF $DATA(^("P"))
SET PSJDD=^("A")
SET X=+PSJDD
DO LC
IF X
SET PSJDM=Q
SET PSJDCA=$PIECE(PSJDD,"^",14)
SET PSJDD=+PSJDD
QUIT
+20 SET Y=1
FOR Q=0:0
SET Q=$ORDER(^UTILITY("DGPM",$JOB,1,Q))
if 'Q
QUIT
IF $GET(^(Q,"A"))
IF $DATA(^("P"))
IF '^("P")
SET X=+^("A")
DO LC
IF X
SET PSJAM=Q
QUIT
+21 IF PSJDM
SET PSJDF=0
DO DIS
+22 IF PSJAM
DO ADM
+23 IF PSJCF
GOTO DONE
+24 ;
TRN ;
+1 SET Y=2
SET Q=0
+2 FOR
SET Q=$ORDER(^UTILITY("DGPM",$JOB,2,Q))
if 'Q
QUIT
IF $GET(^(Q,"A"))
IF $DATA(^("P"))
IF '^("P")
SET X=+^("A")
DO LC
IF X
SET PSJTM=Q
SET $PIECE(PSJPIND,"^",4)=+^UTILITY("DGPM",$JOB,2,Q,"A")
SET PSJTMT=$PIECE(^UTILITY("DGPM",$JOB,2,Q,"A"),"^",18)
QUIT
+3 if 'PSJTM
GOTO DONE
IF $SELECT('PSJTMT:1,PSJTMT<5:0,PSJTMT>26:1,1:PSJTMT<22)
GOTO DONE
+4 KILL VAIP
SET VAIP("D")="L"
DO IN5^VADPT
SET PSJFW=+VAIP(15,4)
SET PSJPAD=+VAIP(13,1)
+5 ;Transfer to authorized or unauthorized absence.
+6 IF PSJTMT<4
SET PSGOEHA=$PIECE($GET(^PS(59.7,1,22,PSJFW,0)),U,PSJTMT+1)
if PSGOEHA'=1&(PSGOEHA'=2)
GOTO DONE
Begin DoDot:1
+7 IF PSGOEHA=1
DO ENHOLD^PSJADT1(1,PSJTMT,PSJPAD,$SELECT(PSJTMT=3:8580,1:8570))
QUIT
+8 SET PSGALO=$SELECT(PSJTMT=3:1090,1:1060)
DO ^PSJADT0
End DoDot:1
GOTO DONE
+9 ;Return from UA or AA
+10 IF PSJTMT>21
if $PIECE(PSJPIND,"^",7)'=2
GOTO DONE
Begin DoDot:1
+11 SET $PIECE(PSJPIND,"^",7)=""
SET $PIECE(PSJPIND,"^",10)=""
SET PSGALO=$SELECT(PSJTMT=22!(PSJTMT=26):8080,1:8070)
SET PSGOEHA=0
DO ENHOLD^PSJADT1(0,$SELECT(PSGALO=8080:3,1:2),PSJPAD,PSGALO)
End DoDot:1
GOTO DONE
+12 if PSJTMT'=4
GOTO DONE
SET PSJADTWD=PSJFW
DO INP^VADPT
IF $DATA(^PS(59.7,1,22,"AFT",PSJFW,+VAIN(4)))
SET PSGALO=1080
DO ENDC^PSJADT0
GOTO DONE
+13 SET FS=$SELECT($DATA(^DIC(42,PSJFW,0)):$PIECE(^(0),"^",3),1:"")
SET TS=$SELECT($DATA(^DIC(42,+VAIN(4),0)):$PIECE(^(0),"^",3),1:"")
IF FS]""
IF TS]""
IF $DATA(^PS(59.7,1,23,"AFT",FS,TS))
SET PSGALO=1070
DO ENDC^PSJADT0
GOTO DONE
+14 DO ENUW^PSJADT1
+15 ;
DONE ;
+1 ; Mark as converted for POE
IF '$DATA(^PS(55,PSGP,0))
DO ENSET0^PSGNE3(PSGP)
SET $PIECE(^PS(55,PSGP,5.1),"^",11)=2
+2 SET ^PS(55,PSGP,5.1)=PSJPIND
SET PSJNKF=1
+3 KILL AM,DA,DIE,DIS,DR,FS,ON,ORIFN,PSGAL,PSGALO,PSGALR,PSGOEHA,PSGTOL,PSGTOO,PSGUOW,PSIVLN,PSIVNST,PSIVREA,PSIVRES,PSJADTWD,PSJAM,PSJCF,PSJDA,PSJDD,PSJDCA,PSJDF,PSJDM,PSJFW,PSJIVDCF,PSJIVON,PSJPAD,PSJPDD,PSJPIND,PSJPWD,PSJPWDN
+4 KILL PSJNOO,P("NAT"),PSJS,PSJTM,PSJTMT,N,P,PS,Q1,Q2,RZ,ST,TS,TSCN,Z
DO ENKV^PSGSETU
if '$DATA(PSJQUIET)&'$DATA(DGQUIET)
WRITE ".done..."
QUIT
+5 ;
DIS ; discharge
+1 KILL VAIP
SET VAIP("E")=PSJDCA
DO IN5^VADPT
SET PSJPAD=+VAIP(13,1)
SET (PSJADTWD,PSJFW)=+VAIP(17,4)
SET PSGALO=$SELECT(PSJDF:1010,1:1030)
DO ENDC^PSJADT0
SET $PIECE(PSJPIND,"^",8)=1
SET PSJCF=1
+2 QUIT
+3 ;
ADM ; admit
+1 ; ************ old way **************************
+2 ;S $P(PSJPIND,"^",3)=+^UTILITY("DGPM",$J,1,PSJAM,"A"),$P(PSJPIND,"^",4)="",$P(PSJPIND,"^",8)="" Q:PSJCF
+3 ;S Q=$O(^DGPM("ATID3",DFN,0)) S:Q Q=$O(^(Q,0)) K VAIP S:Q VAIP("E")=Q S:'Q VAIP("D")="LAST" D IN5^VADPT S PSJPAD=+VAIP(13,1),PSJFW=+VAIP(17,4),PSJADTWD=.5 S PSGALO=1050 D ENDC^PSJADT0 S PSJCF=1
+4 ; ************ new way **************************
+5 SET $PIECE(PSJPIND,"^",3)=+^UTILITY("DGPM",$JOB,1,PSJAM,"A")
SET $PIECE(PSJPIND,"^",4)=""
SET $PIECE(PSJPIND,"^",8)=""
if PSJCF
QUIT
+6 DO IN5^VADPT
SET VAIP("E")=VAIP(14)
SET VAIP("D")="LAST"
DO IN5^VADPT
SET PSJPAD=+VAIP(13,1)
SET PSJFW=+VAIP(17,4)
SET PSJADTWD=.5
SET PSGALO=1050
DO ENDC^PSJADT0
SET PSJCF=1
+7 QUIT
+8 ;
LC ; is movement the latest one of its type?
+1 ;S X=$E(9999999.9999999-X,1,14),Z=$E($O(^DGPM("ATID"_Y,PSGP,0)),1,14) I Z,X>Z S X=0
+2 ; *****************************************************************
+3 ; ** NEW WAY **
+4 NEW PSJRSB
SET PSJRSB("Y")=Y
SET PSJRSB("X")=X
+5 NEW VAIP
if Y=3
SET VAIP("D")="L"
DO IN5^VADPT
SET Z=+VAIP(3)
+6 ; set X again, may have changed during ^VADPT
SET X=PSJRSB("X")
+7 ; change to x<z because dates are not inverted now
IF Z
IF X<Z
SET X=0
+8 ; set Y again, may have changed during ^VADPT
SET Y=PSJRSB("Y")
+9 ; *****************************************************************
+10 ; begin PAL-0402-61286
+11 IF Y=3
IF $SELECT('^UTILITY("DGPM",$JOB,3,Q,"P"):0,X>($GET(PSGDT)):1,$PIECE(PSJDD,"^",18)=$PIECE(^("P"),"^",18):0,$PIECE(PSJDD,"^",18)=12:0,1:$PIECE(PSJDD,"^",18)'=38)
SET X=0
+12 ;I Y=3,$S('^UTILITY("DGPM",$J,3,Q,"P"):0,$P(PSJDD,"^",18)=$P(^("P"),"^",18):0,$P(PSJDD,"^",18)=12:0,1:$P(PSJDD,"^",18)'=38) S X=0
+13 ; end PAL-0402-61286
+14 QUIT
+15 ;
END ; he be dead
+1 SET DFN=DA
NEW D,DA,DB,DC,DE,DG,DH,DI,DIC,DIE,DIG,DIH,DIK,DIR,DIQ,DIU,DIV,DIW,DK,DL,DM,DP,DR,DQ,DU,DV,DW,D0,D1,D2,MR,NX,VAIN,VAIP
+2 ;Naked reference below refers to ^DGPM("ATID1",PSGP,9999999.9999999-X)
+3 ; changed to remove ref to ^DGPM
+4 ; ** OLD WAY **
+5 ;S PSJQUIET=1 D PSJADT S PSJDD=X,PSJDCA=$O(^(+$O(^DGPM("ATID1",PSGP,9999999.9999999-X)),0)),PSJDF=1
+6 ; ******************************************************************
+7 ; ** NEW WAY **
+8 SET PSJQUIET=1
DO PSJADT
SET PSJDD=X
NEW VAIP
SET VAIP("D")=$PIECE(X,".")
DO IN5^VADPT
+9 SET PSJDCA=$GET(VAIP(13))
SET PSJDF=1
+10 ; ******************************************************************
+11 DO INP^VADPT
DO DIS
DO DONE
KILL PSJQUIET
QUIT
