PSGP ;BIR/CML3-PATIENT LOOK-UP ;15 Apr 98 / 9:05 AM
;;5.0;INPATIENT MEDICATIONS ;**10,53,111,181,267,275,279**;16 DEC 97;Build 150
;
; Reference to ^PS(55 is supported by DBIA 2191.
; Reference to ^SDAMA203 is supported by DBIA 4133.
;
ENDPT ; get any patient
N HIT
K DIC,PSGP,Y W !!,"Select "_$S($D(PSGDICA):PSGDICA_" ",1:"")_"PATIENT: " R X:DTIME S:X["^" PSJSTOP=1 I "^"[X S (Y,PSGP)=-1 G DONE
D EN^PSJDPT
I Y'>0 G ENDPT
K DIC
;
CHK ;
;Clean up arrays use in order checks
K PSJEXCPT,PSJOCER
S (DFN,PSGP)=+Y,VA200=1 D INP^VADPT
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=$P($G(^PS(55,PSGP,5.1)),"^",4),PSJPDD="" G CNV
S PSJPCAF="",VAIP("D")="L" D IN5^VADPT I 'VAIP(13,1) W $C(7),!!?3,"PATIENT HAS NEVER BEEN ADMITTED." D ENCONT^PSJP I '(%=1) G ENDPT
S PSJPAD=VAIP(13,1),PSGID=+VAIP(3),X=+VAIP(4)=12!(+VAIP(4)=38),PSGOD=$$ENDTC^PSGMI(PSGID)
I $G(PSGOD) W $C(7),!!?3,"PATIENT IS FOUND TO BE D",$P("ISCHARG^ECEAS","^",X+1),"ED AS OF ",PSGOD,"." D ENCONT^PSJP I '(%=1) G 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="",PSJPDD=PSGID_"^"_PSGOD S:X PSJPDD=PSJPDD_"^1"
;
CNV ;
I $G(DFN) I '$$AA^PSJDPT(DFN) S Y=-1 G ENDPT
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 PSJPWD S PSJSYSW=+$O(^PS(59.6,"B",PSJPWD,0)) I PSJSYSW S PSJSYSW0=$G(^PS(59.6,PSJSYSW,0))
S PSJSYSL="",X=$P(PSJSYSU,";",3)>1,PSJSYSL=$S(X=0:$P(PSJSYSW0,"^",12),1:$P(PSJSYSW0,"^",16))
S PSJDCEXP=$$RECDCEXP^PSJP()
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 ^%ZISC
;
D CLINIC^PSJAC
DONE ;
K DA,DIC,NB,ND,NS,PSGID,PSGOD,VA200,VADM,VAIN,VAIP,VAMT,X,Y(0),Y(0,0) Q
;
COP ;check for appointments in clinics that allowed inpatient orders
S HIT=0 Q:'$$PATCH^XPDUTL("SD*5.3*285")
N SQ,A,VAIP,X,PSJF
D IN5^VADPT
D NOW^%DTC S (PSJF,VASD("F"))=$P(%,".")-1
D SDA^VADPT
S SQ=0 F S SQ=$O(^UTILITY("VASD",$J,SQ)) Q:'SQ S A=^(SQ,"I") I $$SDIMO^SDAMA203($P(A,"^",2),DFN)>0 S HIT=1 Q
I $O(^PS(55,DFN,5,"AUN",PSJF))!($O(^PS(55,DFN,"IV","AIN",PSJF))) S HIT=1
I HIT D ENCONT^PSJP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGP 2692 printed Sep 23, 2025@19:38:44 Page 2
PSGP ;BIR/CML3-PATIENT LOOK-UP ;15 Apr 98 / 9:05 AM
+1 ;;5.0;INPATIENT MEDICATIONS ;**10,53,111,181,267,275,279**;16 DEC 97;Build 150
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA 2191.
+4 ; Reference to ^SDAMA203 is supported by DBIA 4133.
+5 ;
ENDPT ; get any patient
+1 NEW HIT
+2 KILL DIC,PSGP,Y
WRITE !!,"Select "_$SELECT($DATA(PSGDICA):PSGDICA_" ",1:"")_"PATIENT: "
READ X:DTIME
if X["^"
SET PSJSTOP=1
IF "^"[X
SET (Y,PSGP)=-1
GOTO DONE
+3 DO EN^PSJDPT
+4 IF Y'>0
GOTO ENDPT
+5 KILL DIC
+6 ;
CHK ;
+1 ;Clean up arrays use in order checks
+2 KILL PSJEXCPT,PSJOCER
+3 SET (DFN,PSGP)=+Y
SET VA200=1
DO INP^VADPT
+4 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=$PIECE($GET(^PS(55,PSGP,5.1)),"^",4)
SET PSJPDD=""
GOTO CNV
+5 SET PSJPCAF=""
SET VAIP("D")="L"
DO IN5^VADPT
IF 'VAIP(13,1)
WRITE $CHAR(7),!!?3,"PATIENT HAS NEVER BEEN ADMITTED."
DO ENCONT^PSJP
IF '(%=1)
GOTO ENDPT
+6 SET PSJPAD=VAIP(13,1)
SET PSGID=+VAIP(3)
SET X=+VAIP(4)=12!(+VAIP(4)=38)
SET PSGOD=$$ENDTC^PSGMI(PSGID)
+7 IF $GET(PSGOD)
WRITE $CHAR(7),!!?3,"PATIENT IS FOUND TO BE D",$PIECE("ISCHARG^ECEAS","^",X+1),"ED AS OF ",PSGOD,"."
DO ENCONT^PSJP
IF '(%=1)
GOTO ENDPT
+8 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=""
SET PSJPDD=PSGID_"^"_PSGOD
if X
SET PSJPDD=PSJPDD_"^1"
+9 ;
CNV ;
+1 IF $GET(DFN)
IF '$$AA^PSJDPT(DFN)
SET Y=-1
GOTO ENDPT
+2 DO DEM^VADPT
DO PID^VADPT
DO HTWT^PSJAC(DFN)
+3 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")
+4 FOR X="PSJPAD","PSJPDOB","PSJPTD"
IF +@X
SET $PIECE(@X,"^",2)=$$ENDTC^PSGMI(+@X)
+5 ;
WP ; ward parameters
+1 SET PSJSYSW0=""
SET PSJSYSW=0
IF PSJPWD
SET PSJSYSW=+$ORDER(^PS(59.6,"B",PSJPWD,0))
IF PSJSYSW
SET PSJSYSW0=$GET(^PS(59.6,PSJSYSW,0))
+2 SET PSJSYSL=""
SET X=$PIECE(PSJSYSU,";",3)>1
SET PSJSYSL=$SELECT(X=0:$PIECE(PSJSYSW0,"^",12),1:$PIECE(PSJSYSW0,"^",16))
+3 SET PSJDCEXP=$$RECDCEXP^PSJP()
+4 IF PSJSYSL
Begin DoDot:1
+5 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
+6 SET IOP="`"_IOP
KILL %ZIS
SET %ZIS="NQ"
DO ^%ZIS
if 'POP
SET $PIECE(PSJSYSL,"^",2,3)=ION_"^"_IO
DO ^%ZISC
End DoDot:2
End DoDot:1
+7 ;
+8 DO CLINIC^PSJAC
DONE ;
+1 KILL DA,DIC,NB,ND,NS,PSGID,PSGOD,VA200,VADM,VAIN,VAIP,VAMT,X,Y(0),Y(0,0)
QUIT
+2 ;
COP ;check for appointments in clinics that allowed inpatient orders
+1 SET HIT=0
if '$$PATCH^XPDUTL("SD*5.3*285")
QUIT
+2 NEW SQ,A,VAIP,X,PSJF
+3 DO IN5^VADPT
+4 DO NOW^%DTC
SET (PSJF,VASD("F"))=$PIECE(%,".")-1
+5 DO SDA^VADPT
+6 SET SQ=0
FOR
SET SQ=$ORDER(^UTILITY("VASD",$JOB,SQ))
if 'SQ
QUIT
SET A=^(SQ,"I")
IF $$SDIMO^SDAMA203($PIECE(A,"^",2),DFN)>0
SET HIT=1
QUIT
+7 IF $ORDER(^PS(55,DFN,5,"AUN",PSJF))!($ORDER(^PS(55,DFN,"IV","AIN",PSJF)))
SET HIT=1
+8 IF HIT
DO ENCONT^PSJP
+9 QUIT
