Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSJADT

PSJADT.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Reference to ^PS(55 is supported by DBIA# 2191.
  1. ; Reference to ^PS(59.7 is supported by DBIA# 2181.
  1. ; Reference to ^DIC(42 is supported by DBIA# 1377.
  1. ; Reference to ^UTILITY("DGPM" is supported by DBIA# 1181.
  1. ;
  1. W:'$D(PSJQUIET)&'$D(DGQUIET) !!,"...Inpatient Medications check..."
  1. N PSJDEL,PSJSYSU,PSJSYSL,PSJSYSP,PSJSYSP0,PSJSYSW,PSJSYSW0,VA200,VAIN,VAIP,X D ENCV^PSGSETU
  1. 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"
  1. ;Added 1 for Admissions that are deleted to the loop in PSJDEL
  1. ;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
  1. 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
  1. D:$G(PSJDEL)=2!$G(PSJDEL)=6 ENUW^PSJADT1 G:PSJCF DONE Q:$D(PSJQUIET)
  1. 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
  1. 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
  1. I PSJDM S PSJDF=0 D DIS
  1. I PSJAM D ADM
  1. I PSJCF G DONE
  1. ;
  1. TRN ;
  1. S Y=2,Q=0
  1. 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
  1. G:'PSJTM DONE I $S('PSJTMT:1,PSJTMT<5:0,PSJTMT>26:1,1:PSJTMT<22) G DONE
  1. K VAIP S VAIP("D")="L" D IN5^VADPT S PSJFW=+VAIP(15,4),PSJPAD=+VAIP(13,1)
  1. ;Transfer to authorized or unauthorized absence.
  1. 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
  1. .I PSGOEHA=1 D ENHOLD^PSJADT1(1,PSJTMT,PSJPAD,$S(PSJTMT=3:8580,1:8570)) Q
  1. .S PSGALO=$S(PSJTMT=3:1090,1:1060) D ^PSJADT0
  1. ;Return from UA or AA
  1. I PSJTMT>21 G:$P(PSJPIND,"^",7)'=2 DONE D G DONE
  1. .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)
  1. 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
  1. 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
  1. D ENUW^PSJADT1
  1. ;
  1. DONE ;
  1. I '$D(^PS(55,PSGP,0)) D ENSET0^PSGNE3(PSGP) S $P(^PS(55,PSGP,5.1),"^",11)=2 ; Mark as converted for POE
  1. S ^PS(55,PSGP,5.1)=PSJPIND,PSJNKF=1
  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
  1. 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
  1. ;
  1. DIS ; discharge
  1. 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
  1. Q
  1. ;
  1. ADM ; admit
  1. ; ************ old way **************************
  1. ;S $P(PSJPIND,"^",3)=+^UTILITY("DGPM",$J,1,PSJAM,"A"),$P(PSJPIND,"^",4)="",$P(PSJPIND,"^",8)="" Q:PSJCF
  1. ;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
  1. ; ************ new way **************************
  1. S $P(PSJPIND,"^",3)=+^UTILITY("DGPM",$J,1,PSJAM,"A"),$P(PSJPIND,"^",4)="",$P(PSJPIND,"^",8)="" Q:PSJCF
  1. 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
  1. Q
  1. ;
  1. 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
  1. ; *****************************************************************
  1. ; ** NEW WAY **
  1. N PSJRSB S PSJRSB("Y")=Y,PSJRSB("X")=X
  1. N VAIP S:Y=3 VAIP("D")="L" D IN5^VADPT S Z=+VAIP(3)
  1. S X=PSJRSB("X") ; set X again, may have changed during ^VADPT
  1. I Z,X<Z S X=0 ; change to x<z because dates are not inverted now
  1. S Y=PSJRSB("Y") ; set Y again, may have changed during ^VADPT
  1. ; *****************************************************************
  1. ; begin PAL-0402-61286
  1. 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
  1. ;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
  1. ; end PAL-0402-61286
  1. Q
  1. ;
  1. END ; he be dead
  1. 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
  1. ;Naked reference below refers to ^DGPM("ATID1",PSGP,9999999.9999999-X)
  1. ; changed to remove ref to ^DGPM
  1. ; ** OLD WAY **
  1. ;S PSJQUIET=1 D PSJADT S PSJDD=X,PSJDCA=$O(^(+$O(^DGPM("ATID1",PSGP,9999999.9999999-X)),0)),PSJDF=1
  1. ; ******************************************************************
  1. ; ** NEW WAY **
  1. S PSJQUIET=1 D PSJADT S PSJDD=X N VAIP S VAIP("D")=$P(X,".") D IN5^VADPT
  1. S PSJDCA=$G(VAIP(13)),PSJDF=1
  1. ; ******************************************************************
  1. D INP^VADPT,DIS,DONE K PSJQUIET Q