PSGAP.m

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

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