- PSGP ;BIR/CML3-PATIENT LOOK-UP ;29-May-2012 14:31;PLS
- ;;5.0; INPATIENT MEDICATIONS ;**10,53,1011,111,1015**;16 DEC 97;Build 62
- ;
- ; Reference to ^PS(55 is supported by DBIA 2191.
- ; Reference to ^%ZIS is supported by DBIA 10086.
- ; Reference to ^%ZISC is supported by DBIA 10089.
- ; Reference to ^VADPT is supported by DBIA 10061.
- ;
- ; Modified - IHS/MSC/PLS - 03/28/2011 - Line CHK+1
- 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 ;
- D SETPTCX^APSPFUNC(+Y) ;IHS/MSC/PLS - 03/28/11
- 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 COP I 'HIT G ENDPT
- S PSJPAD=VAIP(13,1),PSGID=+VAIP(3),X=+VAIP(4)=12!(+VAIP(4)=38),PSGOD=$$ENDTC^PSGMI(PSGID) W $C(7),!!?3,"PATIENT IS FOUND TO BE D",$P("ISCHARG^ECEAS","^",X+1),"ED AS OF ",PSGOD,"." D COP I 'HIT G:'$D(PSGRETF) 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 ;
- 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=$P(PSJSYSW0,"^",X*4+12)
- S PSJSYSL="",X=$P(PSJSYSU,";",3)>1,PSJSYSL=$S(X=0:$P(PSJSYSW0,"^",12),1:$P(PSJSYSW0,"^",16))
- 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
- ;
- 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
- Q
- PSGP ;BIR/CML3-PATIENT LOOK-UP ;29-May-2012 14:31;PLS
- +1 ;;5.0; INPATIENT MEDICATIONS ;**10,53,1011,111,1015**;16 DEC 97;Build 62
- +2 ;
- +3 ; Reference to ^PS(55 is supported by DBIA 2191.
- +4 ; Reference to ^%ZIS is supported by DBIA 10086.
- +5 ; Reference to ^%ZISC is supported by DBIA 10089.
- +6 ; Reference to ^VADPT is supported by DBIA 10061.
- +7 ;
- +8 ; Modified - IHS/MSC/PLS - 03/28/2011 - Line CHK+1
- 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 ;IHS/MSC/PLS - 03/28/11
- DO SETPTCX^APSPFUNC(+Y)
- +2 SET (DFN,PSGP)=+Y
- SET VA200=1
- DO INP^VADPT
- +3 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
- +4 SET PSJPCAF=""
- SET VAIP("D")="L"
- DO IN5^VADPT
- IF 'VAIP(13,1)
- WRITE $CHAR(7),!!?3,"PATIENT HAS NEVER BEEN ADMITTED."
- DO COP
- IF 'HIT
- GOTO ENDPT
- +5 SET PSJPAD=VAIP(13,1)
- SET PSGID=+VAIP(3)
- SET X=+VAIP(4)=12!(+VAIP(4)=38)
- SET PSGOD=$$ENDTC^PSGMI(PSGID)
- WRITE $CHAR(7),!!?3,"PATIENT IS FOUND TO BE D",$PIECE("ISCHARG^ECEAS","^",X+1),"ED AS OF ",PSGOD,"."
- DO COP
- IF 'HIT
- IF '$DATA(PSGRETF)
- GOTO ENDPT
- +6 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"
- +7 ;
- CNV ;
- +1 DO DEM^VADPT
- DO PID^VADPT
- DO HTWT^PSJAC(DFN)
- +2 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")
- +3 FOR X="PSJPAD","PSJPDOB","PSJPTD"
- IF +@X
- SET $PIECE(@X,"^",2)=$$ENDTC^PSGMI(+@X)
- +4 ;
- 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 ;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 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 ;
- 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 QUIT
