- 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 Jan 18, 2025@03:09:43 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