PSJP ;BIR/CML3-INPATIENT LOOK-UP ; 15 Apr 98 / 9:05 AM
;;5.0;INPATIENT MEDICATIONS ;**10,53,60,181,273,267,275,279**;16 DEC 97;Build 150
;
; Reference to ^PS(55 is supported by DBIA 2191
; Reference to ^PS(59.7 is supported by DBIA 2181
; Reference to ^%ZIS is supported by DBIA 10086
; Reference to ^DICN is supported by DBIA 10009
; Reference to ^DIR is supported by DBIA 10026
; Reference to ^VADPT is supported by DBIA 10061
;
ENDPT ; get any patient
K DIC,PSGP,Y W !!,"Select "_$S($D(PSGDICA):PSGDICA_" ",1:"")_"PATIENT: " R X:DTIME S:'$T X="^" W:'$T $C(7) I "^"[X S (Y,PSGP)=-1 S QFLG=1 G DONE
D EN^PSJDPT
I Y'>0 G ENDPT
K DIC
;
CHK ;
;Clean out arrays use in order checks
K PSJEXCPT,PSJOCER
S (DFN,PSGP)=+Y,VA200=1 D INP^VADPT
I 'VAIN(4) D DEM^VADPT S PSGP(0)=VADM(1),PSJPWD="",PSJPWDN=""
I VAIN(4),$G(PSJCLOR) W $C(7),!!?3,"PATIENT IS CURRENTLY ADMITTED TO ",$P(VAIN(4),"^",2) S PSJPDD=""
I VAIN(4) S PSJPCAF=1_"^"_VAIN(1),PSJPWD=+VAIN(4),PSJPWDN=$P(VAIN(4),"^",2),PSJPTS=+VAIN(3),PSJPTSP=+VAIN(2),PSJPRB=VAIN(5),PSJPAD=+VAIN(7),PSJPDX=VAIN(9),PSJPTD=$S($D(^PS(55,PSGP,5.1)):$P(^(5.1),"^",4),1:""),PSJPDD="" G CNV
S PSJPCAF="",VAIP("D")="L" D IN5^VADPT
I 'VAIP(13,1),'$G(PSJCLOR) W $C(7),!!?3,"PATIENT HAS NEVER BEEN ADMITTED." D ENCONT G:%'=1 ENDPT S PSJPDD=""
;*273 - Recognize patient death not from discharge
D DEM^VADPT
S PSGID=$S($G(VADM(6))]"":+VADM(6),1:+VAIP(3)),X=+VAIP(4)=12!(+VAIP(4)=38)!($G(VADM(6))),PSGOD=$$ENDTC^PSGMI(PSGID)
I $S(X:1,1:VAIP(13,1)) Q:($G(PSJCLOR)&'(X)) W $C(7),!!?3,"PATIENT IS FOUND TO BE ",$P("DISCHARGED^DECEASED","^",X+1)," AS OF ",PSGOD,"." S PSJH=$S(X:2,1:3),PSJPDD=PSGID_"^"_PSGOD S:X PSJPDD=PSJPDD_"^1" D ENCONT G:%'=1 ENDPT
S PSJPAD=VAIP(13,1),PSJPWD=+VAIP(5),PSJPWDN=$P(VAIP(5),"^",2),PSJPRB=$P(VAIP(6),"^",2),PSJPTSP=+VAIP(7),PSJPTS=+VAIP(8),PSJPDX=VAIP(9),PSJPTD=""
;
CNV ;
I $G(DFN) I '$$AA^PSJDPT(DFN) S Y=-1 G ENDPT
I $D(PSJEXTP) W ! K DIR S DIR(0)="DO",DIR("A")="Date to start searching from (optional)",DIR("?")="Enter a date to start searching from, or <RETURN> for all orders" D ^DIR S PSJHDATE=Y K DIR
D DEM^VADPT,PID^VADPT,HTWT^PSJAC(DFN)
S PSGP(0)=VADM(1),PSJPSSN=VADM(2),PSJPDOB=+VADM(3),PSJPAGE=VADM(4),PSJPSEX=$S(VADM(5)]"":VADM(5),1:"?^____"),PSJPPID=VA("PID"),PSJPBID=VA("BID")
F X="PSJPAD","PSJPDOB","PSJPTD" I @X S $P(@X,"^",2)=$$ENDTC^PSGMI(+@X)
;
WP ; ward parameters
S PSJSYSW0="",PSJSYSW=0 I $G(PSJPWD) S PSJSYSW=+$O(^PS(59.6,"B",PSJPWD,0)) I PSJSYSW S PSJSYSW0=$G(^PS(59.6,PSJSYSW,0))
; *OLD CODE* S PSJSYSL="",X=$P(PSJSYSU,";",3)>1,PSJSYSL=$P(PSJSYSW0,"^",X*4+12)
S PSJSYSL="",X=$P(PSJSYSU,";",3)>1,PSJSYSL=$S(X=0:$P(PSJSYSW0,"^",12),1:$P(PSJSYSW0,"^",16))
S PSJDCEXP=$$RECDCEXP()
I PSJSYSL D
.S:X X='$P(PSJSYSP0,"^",10) S IOP=$S($P(PSJSYSP0,"^",13)]"":$P(PSJSYSP0,"^",13),$P(PSJSYSW0,"^",19+X)]"":$P(PSJSYSW0,"^",19+X),1:"") I IOP]"" D
..S IOP="`"_IOP K %ZIS S %ZIS="NQ" D ^%ZIS S:'POP $P(PSJSYSL,"^",2,3)=ION_"^"_IO D HOME^%ZIS
;
DONE ;
K DA,DIC,NB,ND,NS,PSGID,PSGOD,VA200,VAIP,VAMT,X,Y(0),Y(0,0),QFLG Q
;
ENCONT ;
I $D(PSGH) S %=1 Q
F FQ=0:0 W !!,"Do you wish to continue with this patient" S %=0 D YN^DICN Q:% W:%Y'?1."?" $C(7) W " (A 'YES' or 'NO' response is required.)" D:%Y?1."?" @("CH"_PSJH)
S:%'=1 Y=-1 Q
;
CH1 ;
W !!?2,"The patient selected has never been admitted to this medical facility. You",!,"will be able to enter IV orders for this patient but NOT Unit Dose orders." Q
CH2 ;
W !!?2,"This patient is shown as deceased. You will not be able to enter orders for",!,"this patient." Q
CH3 ;
W !!?2,"This patient is shown to be currently discharged. You will be able to enter",!,"IV orders for this patient but NOT Unit Dose orders." Q
Q
RECDCEXP() ;
;Determent the Hours to display Recently DC/Expired orders on the short profile
;Returning P1^P2
;P1 = Number of hours defined in 59.6 or 59.7. Set to 24 if no value set in either file.
;P2 = Date.time from Now - P1 hours
;
NEW PSJDCEXP,PSJWD,PSJWD1,PSJSYS,X,%,PSJLPDAY
S PSJWD1=$S(+$G(PSJPWD):PSJPWD,+$G(VAIN(4)):+VAIN(4),1:0)
S:PSJWD1 X=$O(^PS(59.6,"B",PSJWD1,0))
S:+$G(X) PSJWD=$P($G(^PS(59.6,X,0)),U,33)
S PSJSYS=+$P($G(^PS(59.7,1,26)),U,8)
S PSJDCEXP=$S($G(PSJWD):PSJWD,PSJSYS:PSJSYS,1:24)
D NOW^%DTC
S X=$$FMADD^XLFDT(%,0,-PSJDCEXP,0,0)
; If Long Profile, use last admission date if it's older than recently dc'd/expired parameter
I $G(PSJOL)="L"&($G(PSJPAD)) S PSJLPDAY=$$FMDIFF^XLFDT(%,+$G(PSJPAD),1)*24 I PSJLPDAY>0&(PSJLPDAY>PSJDCEXP) S PSJDCEXP=+$G(PSJPAD),X=PSJLPDAY
Q PSJDCEXP_U_X
;
CLORCHK(PSJPTIEN) ; Return patient does (1) or does not (0) have any clinic orders.
N PSGP,ND,C,DN,PSGSS,Y,X,PSJPAD,TMPCLIN,DFN,PSJBEG,PSJEND,PSJDCEXP,PSJOL,PSJOS,VAIN,VADM,VAIP S TMPCLIN=""
S (DFN,PSGP,Y)=+PSJPTIEN,PSGSS="P",VA200=1 D INP^VADPT,IN5^VADPT
D NOW^%DTC S PSJBEG=$$FMADD^XLFDT(+$G(X),-3650),PSJEND=$$FMADD^XLFDT(+$G(X),3650)
D DEM^VADPT S PSJPAD=VAIP(13,1),PSJPBID=VA("BID"),PSGP(0)=VADM(1)
K ^TMP("PSJ",$J),^TMP("PSJON",$J),^TMP("PSJPRO",$J),^TMP("PSJCLOR",$J)
D EN^PSJCLOR3(3) I $D(^TMP("PSJ",$J)) K ^TMP("PSJ",$J) Q 1
I '$D(^TMP("PSJ",$J)) Q 0
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJP 5173 printed Apr 09, 2024@21:07:03 Page 2
PSJP ;BIR/CML3-INPATIENT LOOK-UP ; 15 Apr 98 / 9:05 AM
+1 ;;5.0;INPATIENT MEDICATIONS ;**10,53,60,181,273,267,275,279**;16 DEC 97;Build 150
+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 ^%ZIS is supported by DBIA 10086
+6 ; Reference to ^DICN is supported by DBIA 10009
+7 ; Reference to ^DIR is supported by DBIA 10026
+8 ; Reference to ^VADPT is supported by DBIA 10061
+9 ;
ENDPT ; get any patient
+1 KILL DIC,PSGP,Y
WRITE !!,"Select "_$SELECT($DATA(PSGDICA):PSGDICA_" ",1:"")_"PATIENT: "
READ X:DTIME
if '$TEST
SET X="^"
if '$TEST
WRITE $CHAR(7)
IF "^"[X
SET (Y,PSGP)=-1
SET QFLG=1
GOTO DONE
+2 DO EN^PSJDPT
+3 IF Y'>0
GOTO ENDPT
+4 KILL DIC
+5 ;
CHK ;
+1 ;Clean out arrays use in order checks
+2 KILL PSJEXCPT,PSJOCER
+3 SET (DFN,PSGP)=+Y
SET VA200=1
DO INP^VADPT
+4 IF 'VAIN(4)
DO DEM^VADPT
SET PSGP(0)=VADM(1)
SET PSJPWD=""
SET PSJPWDN=""
+5 IF VAIN(4)
IF $GET(PSJCLOR)
WRITE $CHAR(7),!!?3,"PATIENT IS CURRENTLY ADMITTED TO ",$PIECE(VAIN(4),"^",2)
SET PSJPDD=""
+6 IF VAIN(4)
SET PSJPCAF=1_"^"_VAIN(1)
SET PSJPWD=+VAIN(4)
SET PSJPWDN=$PIECE(VAIN(4),"^",2)
SET PSJPTS=+VAIN(3)
SET PSJPTSP=+VAIN(2)
SET PSJPRB=VAIN(5)
SET PSJPAD=+VAIN(7)
SET PSJPDX=VAIN(9)
SET PSJPTD=$SELECT($DATA(^PS(55,PSGP,5.1)):$PIECE(^(5.1),"^",4),1:"")
SET PSJPDD=""
GOTO CNV
+7 SET PSJPCAF=""
SET VAIP("D")="L"
DO IN5^VADPT
+8 IF 'VAIP(13,1)
IF '$GET(PSJCLOR)
WRITE $CHAR(7),!!?3,"PATIENT HAS NEVER BEEN ADMITTED."
DO ENCONT
if %'=1
GOTO ENDPT
SET PSJPDD=""
+9 ;*273 - Recognize patient death not from discharge
+10 DO DEM^VADPT
+11 SET PSGID=$SELECT($GET(VADM(6))]"":+VADM(6),1:+VAIP(3))
SET X=+VAIP(4)=12!(+VAIP(4)=38)!($GET(VADM(6)))
SET PSGOD=$$ENDTC^PSGMI(PSGID)
+12 IF $SELECT(X:1,1:VAIP(13,1))
if ($GET(PSJCLOR)&'(X))
QUIT
WRITE $CHAR(7),!!?3,"PATIENT IS FOUND TO BE ",$PIECE("DISCHARGED^DECEASED","^",X+1)," AS OF ",PSGOD,"."
SET PSJH=$SELECT(X:2,1:3)
SET PSJPDD=PSGID_"^"_PSGOD
if X
SET PSJPDD=PSJPDD_"^1"
DO ENCONT
if %'=1
GOTO ENDPT
+13 SET PSJPAD=VAIP(13,1)
SET PSJPWD=+VAIP(5)
SET PSJPWDN=$PIECE(VAIP(5),"^",2)
SET PSJPRB=$PIECE(VAIP(6),"^",2)
SET PSJPTSP=+VAIP(7)
SET PSJPTS=+VAIP(8)
SET PSJPDX=VAIP(9)
SET PSJPTD=""
+14 ;
CNV ;
+1 IF $GET(DFN)
IF '$$AA^PSJDPT(DFN)
SET Y=-1
GOTO ENDPT
+2 IF $DATA(PSJEXTP)
WRITE !
KILL DIR
SET DIR(0)="DO"
SET DIR("A")="Date to start searching from (optional)"
SET DIR("?")="Enter a date to start searching from, or <RETURN> for all orders"
DO ^DIR
SET PSJHDATE=Y
KILL DIR
+3 DO DEM^VADPT
DO PID^VADPT
DO HTWT^PSJAC(DFN)
+4 SET PSGP(0)=VADM(1)
SET PSJPSSN=VADM(2)
SET PSJPDOB=+VADM(3)
SET PSJPAGE=VADM(4)
SET PSJPSEX=$SELECT(VADM(5)]"":VADM(5),1:"?^____")
SET PSJPPID=VA("PID")
SET PSJPBID=VA("BID")
+5 FOR X="PSJPAD","PSJPDOB","PSJPTD"
IF @X
SET $PIECE(@X,"^",2)=$$ENDTC^PSGMI(+@X)
+6 ;
WP ; ward parameters
+1 SET PSJSYSW0=""
SET PSJSYSW=0
IF $GET(PSJPWD)
SET PSJSYSW=+$ORDER(^PS(59.6,"B",PSJPWD,0))
IF PSJSYSW
SET PSJSYSW0=$GET(^PS(59.6,PSJSYSW,0))
+2 ; *OLD CODE* S PSJSYSL="",X=$P(PSJSYSU,";",3)>1,PSJSYSL=$P(PSJSYSW0,"^",X*4+12)
+3 SET PSJSYSL=""
SET X=$PIECE(PSJSYSU,";",3)>1
SET PSJSYSL=$SELECT(X=0:$PIECE(PSJSYSW0,"^",12),1:$PIECE(PSJSYSW0,"^",16))
+4 SET PSJDCEXP=$$RECDCEXP()
+5 IF PSJSYSL
Begin DoDot:1
+6 if X
SET X='$PIECE(PSJSYSP0,"^",10)
SET IOP=$SELECT($PIECE(PSJSYSP0,"^",13)]"":$PIECE(PSJSYSP0,"^",13),$PIECE(PSJSYSW0,"^",19+X)]"":$PIECE(PSJSYSW0,"^",19+X),1:"")
IF IOP]""
Begin DoDot:2
+7 SET IOP="`"_IOP
KILL %ZIS
SET %ZIS="NQ"
DO ^%ZIS
if 'POP
SET $PIECE(PSJSYSL,"^",2,3)=ION_"^"_IO
DO HOME^%ZIS
End DoDot:2
End DoDot:1
+8 ;
DONE ;
+1 KILL DA,DIC,NB,ND,NS,PSGID,PSGOD,VA200,VAIP,VAMT,X,Y(0),Y(0,0),QFLG
QUIT
+2 ;
ENCONT ;
+1 IF $DATA(PSGH)
SET %=1
QUIT
+2 FOR FQ=0:0
WRITE !!,"Do you wish to continue with this patient"
SET %=0
DO YN^DICN
if %
QUIT
if %Y'?1."?"
WRITE $CHAR(7)
WRITE " (A 'YES' or 'NO' response is required.)"
if %Y?1."?"
DO @("CH"_PSJH)
+3 if %'=1
SET Y=-1
QUIT
+4 ;
CH1 ;
+1 WRITE !!?2,"The patient selected has never been admitted to this medical facility. You",!,"will be able to enter IV orders for this patient but NOT Unit Dose orders."
QUIT
CH2 ;
+1 WRITE !!?2,"This patient is shown as deceased. You will not be able to enter orders for",!,"this patient."
QUIT
CH3 ;
+1 WRITE !!?2,"This patient is shown to be currently discharged. You will be able to enter",!,"IV orders for this patient but NOT Unit Dose orders."
QUIT
+2 QUIT
RECDCEXP() ;
+1 ;Determent the Hours to display Recently DC/Expired orders on the short profile
+2 ;Returning P1^P2
+3 ;P1 = Number of hours defined in 59.6 or 59.7. Set to 24 if no value set in either file.
+4 ;P2 = Date.time from Now - P1 hours
+5 ;
+6 NEW PSJDCEXP,PSJWD,PSJWD1,PSJSYS,X,%,PSJLPDAY
+7 SET PSJWD1=$SELECT(+$GET(PSJPWD):PSJPWD,+$GET(VAIN(4)):+VAIN(4),1:0)
+8 if PSJWD1
SET X=$ORDER(^PS(59.6,"B",PSJWD1,0))
+9 if +$GET(X)
SET PSJWD=$PIECE($GET(^PS(59.6,X,0)),U,33)
+10 SET PSJSYS=+$PIECE($GET(^PS(59.7,1,26)),U,8)
+11 SET PSJDCEXP=$SELECT($GET(PSJWD):PSJWD,PSJSYS:PSJSYS,1:24)
+12 DO NOW^%DTC
+13 SET X=$$FMADD^XLFDT(%,0,-PSJDCEXP,0,0)
+14 ; If Long Profile, use last admission date if it's older than recently dc'd/expired parameter
+15 IF $GET(PSJOL)="L"&($GET(PSJPAD))
SET PSJLPDAY=$$FMDIFF^XLFDT(%,+$GET(PSJPAD),1)*24
IF PSJLPDAY>0&(PSJLPDAY>PSJDCEXP)
SET PSJDCEXP=+$GET(PSJPAD)
SET X=PSJLPDAY
+16 QUIT PSJDCEXP_U_X
+17 ;
CLORCHK(PSJPTIEN) ; Return patient does (1) or does not (0) have any clinic orders.
+1 NEW PSGP,ND,C,DN,PSGSS,Y,X,PSJPAD,TMPCLIN,DFN,PSJBEG,PSJEND,PSJDCEXP,PSJOL,PSJOS,VAIN,VADM,VAIP
SET TMPCLIN=""
+2 SET (DFN,PSGP,Y)=+PSJPTIEN
SET PSGSS="P"
SET VA200=1
DO INP^VADPT
DO IN5^VADPT
+3 DO NOW^%DTC
SET PSJBEG=$$FMADD^XLFDT(+$GET(X),-3650)
SET PSJEND=$$FMADD^XLFDT(+$GET(X),3650)
+4 DO DEM^VADPT
SET PSJPAD=VAIP(13,1)
SET PSJPBID=VA("BID")
SET PSGP(0)=VADM(1)
+5 KILL ^TMP("PSJ",$JOB),^TMP("PSJON",$JOB),^TMP("PSJPRO",$JOB),^TMP("PSJCLOR",$JOB)
+6 DO EN^PSJCLOR3(3)
IF $DATA(^TMP("PSJ",$JOB))
KILL ^TMP("PSJ",$JOB)
QUIT 1
+7 IF '$DATA(^TMP("PSJ",$JOB))
QUIT 0
+8 QUIT 0
