PSGAP ;BIR/CML3-ACTION PROFILE (#1) ;12 Mar 98 / 9:28 AM
;;5.0; INPATIENT MEDICATIONS ;**8,111**;16 DEC 97
N PSJNEW,PSGPTMP,PPAGE S PSJNEW=1
D ENCV^PSGSETU I $D(XQUIT) Q
;
START ;
N PSGWD,PSJPWDO
S (PSGP,PSGAPWD,PSGAPWG)=0,(PSGAPWDN,PSGAPWGN)="",PSGSSH="AP",PSGY=1 S PSGPTMP=0,PPAGE=1 D GWP^PSJPDIR G:'$D(PSJSEL)!($G(PSJSTOP)=1) DONE D @PSJSEL("SELECT")
S PSGSS=PSJSEL("SELECT") D EN^PSGAP0
G:$G(PSJSTOP) START
;
DONE ;
D ENKV^PSGSETU K CA,CNTR,DFN,DIAG,DO,DRG,FD,N,NF,ND,ND2,PSJJORD,PAGE,PDOB,PN,PND,PSEX,PSGAP,PSGAPTM,PSGAPWD,PSGAPWDN,PSGAPWG,PSGAPWGN,PSGDICA,PSGPAT,PSGSS,PSGSSH
K PFLG,QFLG,PSGMTYPE,PSGFL,PSGEXPDT,PSGY,PSJSI,PSJSTOP,PSJACNWP,PSJOPC,PSJSEL,PT,RB,RTE,SD,SI,SM,ST,STRT,STP,STT,TM,WS,WT,ZTOUT,ZTSK,PSJDLW
K ^TMP($J)
Q
;
G ; get ward group
S PSGAPWG=+PSJSEL("WG"),PSGAPWGN=$P(PSJSEL("WG"),"^",2) Q
;
W ; get ward (and Admin. Team if present)
S (PSGWD,PSGAPWD)=+PSJSEL("W"),PSGAPWDN=$P(PSJSEL("W"),"^",2)
I $D(PSJSEL("TM")) S TM="",PSJTEAM=1 F S TM=$O(PSJSEL("TM",TM)) Q:TM="" S PSGAPTM(TM)=TM
Q
;
P ; get patient
S PT="" F S PT=$O(PSJSEL("P",PT)) Q:PT="" S DFN="",DFN=$O(PSJSEL("P",PT,DFN)) Q:'DFN S PSGPAT(DFN)=""
Q
;
ENOR ;
D ENCV^PSGSETU I $D(XQUIT) Q
S PSGP=+ORVP D PSJAC2^PSJAC(1) S PSGPAT=PSGP,PSGPAT(DFN)="",(PSGAPWD,PSGAPWG)=0,(PSGAPWDN,PSGAPWGN)="",PSGSS="P" D EN^PSGAP0 S PSJNKF=1 G DONE
ENLM ;Entry point from PSJ LM AP1 protocol
N PSJNEW,PSGPTMP,PPAGE S PSJNEW=1
S PSGPTMP=0,PPAGE=1,PSGSSH="AP",PSGY=1
D ENCV^PSGSETU I $D(XQUIT) Q
S PSGPAT=PSGP,PSGPAT(DFN)="",(PSGAPWD,PSGAPWG)=0,(PSGAPWDN,PSGAPWGN)="",PSGSS="P" D EN^PSGAP0 S PSJNKF=1 G DONE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGAP 1642 printed Sep 23, 2025@19:36:52 Page 2
PSGAP ;BIR/CML3-ACTION PROFILE (#1) ;12 Mar 98 / 9:28 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**8,111**;16 DEC 97
+2 NEW PSJNEW,PSGPTMP,PPAGE
SET PSJNEW=1
+3 DO ENCV^PSGSETU
IF $DATA(XQUIT)
QUIT
+4 ;
START ;
+1 NEW PSGWD,PSJPWDO
+2 SET (PSGP,PSGAPWD,PSGAPWG)=0
SET (PSGAPWDN,PSGAPWGN)=""
SET PSGSSH="AP"
SET PSGY=1
SET PSGPTMP=0
SET PPAGE=1
DO GWP^PSJPDIR
if '$DATA(PSJSEL)!($GET(PSJSTOP)=1)
GOTO DONE
DO @PSJSEL("SELECT")
+3 SET PSGSS=PSJSEL("SELECT")
DO EN^PSGAP0
+4 if $GET(PSJSTOP)
GOTO START
+5 ;
DONE ;
+1 DO ENKV^PSGSETU
KILL CA,CNTR,DFN,DIAG,DO,DRG,FD,N,NF,ND,ND2,PSJJORD,PAGE,PDOB,PN,PND,PSEX,PSGAP,PSGAPTM,PSGAPWD,PSGAPWDN,PSGAPWG,PSGAPWGN,PSGDICA,PSGPAT,PSGSS,PSGSSH
+2 KILL PFLG,QFLG,PSGMTYPE,PSGFL,PSGEXPDT,PSGY,PSJSI,PSJSTOP,PSJACNWP,PSJOPC,PSJSEL,PT,RB,RTE,SD,SI,SM,ST,STRT,STP,STT,TM,WS,WT,ZTOUT,ZTSK,PSJDLW
+3 KILL ^TMP($JOB)
+4 QUIT
+5 ;
G ; get ward group
+1 SET PSGAPWG=+PSJSEL("WG")
SET PSGAPWGN=$PIECE(PSJSEL("WG"),"^",2)
QUIT
+2 ;
W ; get ward (and Admin. Team if present)
+1 SET (PSGWD,PSGAPWD)=+PSJSEL("W")
SET PSGAPWDN=$PIECE(PSJSEL("W"),"^",2)
+2 IF $DATA(PSJSEL("TM"))
SET TM=""
SET PSJTEAM=1
FOR
SET TM=$ORDER(PSJSEL("TM",TM))
if TM=""
QUIT
SET PSGAPTM(TM)=TM
+3 QUIT
+4 ;
P ; get patient
+1 SET PT=""
FOR
SET PT=$ORDER(PSJSEL("P",PT))
if PT=""
QUIT
SET DFN=""
SET DFN=$ORDER(PSJSEL("P",PT,DFN))
if 'DFN
QUIT
SET PSGPAT(DFN)=""
+2 QUIT
+3 ;
ENOR ;
+1 DO ENCV^PSGSETU
IF $DATA(XQUIT)
QUIT
+2 SET PSGP=+ORVP
DO PSJAC2^PSJAC(1)
SET PSGPAT=PSGP
SET PSGPAT(DFN)=""
SET (PSGAPWD,PSGAPWG)=0
SET (PSGAPWDN,PSGAPWGN)=""
SET PSGSS="P"
DO EN^PSGAP0
SET PSJNKF=1
GOTO DONE
ENLM ;Entry point from PSJ LM AP1 protocol
+1 NEW PSJNEW,PSGPTMP,PPAGE
SET PSJNEW=1
+2 SET PSGPTMP=0
SET PPAGE=1
SET PSGSSH="AP"
SET PSGY=1
+3 DO ENCV^PSGSETU
IF $DATA(XQUIT)
QUIT
+4 SET PSGPAT=PSGP
SET PSGPAT(DFN)=""
SET (PSGAPWD,PSGAPWG)=0
SET (PSGAPWDN,PSGAPWGN)=""
SET PSGSS="P"
DO EN^PSGAP0
SET PSJNKF=1
GOTO DONE
