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

PSGP.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Reference to ^PS(55 is supported by DBIA 2191.
  1. ; Reference to ^SDAMA203 is supported by DBIA 4133.
  1. ;
  1. ENDPT ; get any patient
  1. N HIT
  1. 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
  1. D EN^PSJDPT
  1. I Y'>0 G ENDPT
  1. K DIC
  1. ;
  1. CHK ;
  1. ;Clean up arrays use in order checks
  1. K PSJEXCPT,PSJOCER
  1. S (DFN,PSGP)=+Y,VA200=1 D INP^VADPT
  1. 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
  1. 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
  1. S PSJPAD=VAIP(13,1),PSGID=+VAIP(3),X=+VAIP(4)=12!(+VAIP(4)=38),PSGOD=$$ENDTC^PSGMI(PSGID)
  1. 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
  1. 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"
  1. ;
  1. CNV ;
  1. I $G(DFN) I '$$AA^PSJDPT(DFN) S Y=-1 G ENDPT
  1. D DEM^VADPT,PID^VADPT,HTWT^PSJAC(DFN)
  1. 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")
  1. F X="PSJPAD","PSJPDOB","PSJPTD" I +@X S $P(@X,"^",2)=$$ENDTC^PSGMI(+@X)
  1. ;
  1. WP ; ward parameters
  1. 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))
  1. S PSJSYSL="",X=$P(PSJSYSU,";",3)>1,PSJSYSL=$S(X=0:$P(PSJSYSW0,"^",12),1:$P(PSJSYSW0,"^",16))
  1. S PSJDCEXP=$$RECDCEXP^PSJP()
  1. I PSJSYSL D
  1. .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
  1. ..S IOP="`"_IOP K %ZIS S %ZIS="NQ" D ^%ZIS S:'POP $P(PSJSYSL,"^",2,3)=ION_"^"_IO D ^%ZISC
  1. ;
  1. D CLINIC^PSJAC
  1. DONE ;
  1. K DA,DIC,NB,ND,NS,PSGID,PSGOD,VA200,VADM,VAIN,VAIP,VAMT,X,Y(0),Y(0,0) Q
  1. ;
  1. COP ;check for appointments in clinics that allowed inpatient orders
  1. S HIT=0 Q:'$$PATCH^XPDUTL("SD*5.3*285")
  1. N SQ,A,VAIP,X,PSJF
  1. D IN5^VADPT
  1. D NOW^%DTC S (PSJF,VASD("F"))=$P(%,".")-1
  1. D SDA^VADPT
  1. 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
  1. I $O(^PS(55,DFN,5,"AUN",PSJF))!($O(^PS(55,DFN,"IV","AIN",PSJF))) S HIT=1
  1. I HIT D ENCONT^PSJP
  1. Q