- 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**;16 DEC 97
- ;
- ; 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 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
- 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
- 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**;16 DEC 97
- +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
- FOR PSJDEL=1,2,3,6
- IF $GET(^UTILITY("DGPM",$JOB,PSJDEL,DGPMDA,"P"))
- IF '$GET(^("A"))
- DO ENDEL^PSJADT1(DFN,DGPMP,$PIECE($GET(^UTILITY("DGPM",$JOB,+PSJDEL,"P")),U,18),PSJDEL)
- SET PSJCF=1
- QUIT
- +14 IF $GET(PSJDEL)=2!$GET(PSJDEL)=6
- DO ENUW^PSJADT1
- IF PSJCF
- GOTO DONE
- IF $DATA(PSJQUIET)
- QUIT
- +15 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
- +16 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
- +17 IF PSJDM
- SET PSJDF=0
- DO DIS
- +18 IF PSJAM
- DO ADM
- +19 IF PSJCF
- GOTO DONE
- +20 ;
- 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
