- 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 Mar 13, 2025@21:05:39 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
