PSGCAP ;BIR/CML3-ACTION PROFILE (#2) ;04 APR 96 / 1:10 PM
;;5.0; INPATIENT MEDICATIONS ;**111**;16 DEC 97
N PSJNEW,PSGPTMP,PPAGE S PSJNEW=1
;
D ENCV^PSGSETU I $D(XQUIT) Q
;
START ;
S (PSGAP,PSGP,PSGAPWD,PSGAPWG)=0,(PSGAPWDN,PSGAPWGN)="",PSGSSH="AP" S PSGPTMP=0,PPAGE=1
D ^PSGSEL G:PSGSS="^"!(PSGSS="") DONE D @PSGSS I (Y'="^OTHER"),(Y'>0) W !!?3,"No patient(s) selected. Option terminated." G START
;
ORS I '$G(PSGAPWG) S PSGAPS="P" G ORS1
S PSGAPS="T" I $S(PSGSS'="P":1,1:PSGPAT>1) F W !!,"Sort Action Profiles by (T)eam or Treating (P)rovider? T// " R PSGAPS:DTIME D Q1 Q:PSGAPS]""
ORS1 G:PSGAPS="^" START D NOW^%DTC S PSGDT=% F N="START","STOP" D GDT G:$D(DIRUT) START
F W !!,"Print (A)ll active orders, or (E)xpiring orders only? A// " R PSGAPO:DTIME D Q2 Q:PSGAPO]""
G:PSGAPO="^" START
G:$$MEDTYPE^PSJMDIR($G(PSGWD)) START S PSGMTYPE=Y
K ZTSAVE F X="PSGAPS","PSGAPO","PSGAPSD","PSGAPFD","PSGMTYPE","PSGP","PSGSS","PSGAPWD","PSGAPWG","PSGAPWDN","PSGAPWGN","PSGPAT(","PSGPTMP","PPAGE" S ZTSAVE(X)=""
S PSGTIR="ENQ^PSGCAP0",ZTDESC="ACTION PROFILE" D ENDEV^PSGTI G:POP START G:$D(IO("Q")) DONE
W !,"...this may take a few minutes...(you really should QUEUE this report)..." D ENQ^PSGCAP0
;
;
DONE ;
D ENKV^PSGSETU K CA,CNTR,DIAG,DO,DRG,FD,LQ,N,NF,ND,ND2,PSJJORD,PAGE,PDOB,PN,PND,PSEX,PSGAP,PSGAPWD,PSGAPWDN,PSGAPWG,PSGAPWGN,PSGDICA,PSGPAT,PSGSS
K PSGSSH,RB,RTE,SD,SI,SM,ST,STRT,STP,STT,WS,WT,S1,ZTOUT,PSGAPFD,PSGAPSD,PSGAPS,PSGAPO,PSJACNWP,PSJDLW,PSJOPC,PSJPWDO,PSGWD
K PSGADR,PSGALG,PSGEXPDT,PSGMTYPE,PSJSI,PSJSTOP,PSJTEAM,PST,QST
K ^TMP($J)
Q
;
GDT ;
K DIR NEW MINDT S:N="START" MINDT=PSGDT-.0001,DIR("B")="NOW" S:N="STOP" MINDT=PSGAPSD,DIR("B")=$$ENDD^PSGMI(PSGAPSD)
S DIR(0)="DA^"_MINDT_":9999999.9999:EFTX",DIR("?")="^D DTM^PSGCAP",DIR("A")="Enter "_$S(N["R":"START",1:"STOP")_" date/time: " D ^DIR K DIR Q:$D(DIRUT)
I X'="^" S:N["R" PSGAPSD=$S(Y'>0:PSGDT,Y#1:+$E(Y,1,12),1:Y+.0001) S:N["O" PSGAPFD=$S(Y'>0:9999999,Y#1:+$E(Y,1,12),1:Y+.24)
Q
;
G ; get ward group
S DIC="^PS(57.5,",DIC(0)="QEAMZ",DIC("A")="Select WARD GROUP: " W ! D ^DIC K DIC S:Y>0 PSGAPWG=+Y,PSGAPWGN=Y(0,0) I Y<0,X="^OTHER" D
. S (Y,PSGAPWG,PSGAPWGN)="^OTHER",(PSGAPWD,PSGAPWDN)="zz"
Q
;
C ;
K DIR S DIR(0)="FAO",DIR("A")="Select CLINIC: "
S DIR("?")="^D CDIC^PSGVBW" W ! D ^DIR
CDIC ;
K DIC S DIC="^SC(",DIC(0)="QEMIZ" D ^DIC K DIC S:+Y>0 CL=+Y
W:X["?" !!,"Enter the clinic you want to use to select patients for processing.",!
Q
L ;
K DIR S DIR(0)="FAO",DIR("A")="Select CLINIC GROUP: "
S DIR("?")="^D LDIC^PSGVBW" W ! D ^DIR
LDIC ;
K DIC S DIC="^PS(57.8,",DIC(0)="QEMI" D ^DIC K DIC S:+Y>0 CG=+Y
W:X["?" !!,"Enter the name of the clinic group you want to use to select patients for processing."
Q
W ; get ward
S DIC="^DIC(42,",DIC(0)="QEAMZ",DIC("A")="Select WARD: " W ! D ^DIC K DIC S:Y>0 (PSGWD,PSGAPWD)=+Y,PSGAPWDN=Y(0,0) Q
;
P ; get patient
K PSGPAT,PSJPWDO,PSGWD
S PSGPAT=0 F CNTR=1:1 S:CNTR>1 PSGDICA="another" D ENP^PSGGAO Q:PSGP'>0 S PSGPAT(PSGP)="",PSGPAT=PSGPAT+1 S:'$G(PSJPWDO) (PSGWD,PSJPWDO)=PSJPWD S PSGWD=$S('$G(PSGWD):0,PSJPWDO=PSJPWD:PSJPWD,1:0)
S Y=$S(PSGPAT:1,1:-1) K PSGDICA Q
;
DTM ;
S Y=PSGDT D D^DIQ S T=$P(Y,"@",2),Y=$P(Y,",")
W !!?2,"Enter a ",N," date. If a time is not entered for the ",N," date, the",!,$S(N["R":"beginning",1:"end")," of the day is assumed and used."
W !?2,"If you wish to enter a ",$S(N["R":"start",1:"stop")," date of ",Y,", you must enter a TIME of day",!,"of ",T," or greater. Any date after ",Y," does not need time entered.",! S Y=-1 Q
;
Q1 ;
W:'$T $C(7) S:'$T PSGAPS="^" Q:PSGAPS="^"
I PSGAPS="" S PSGAPS="T" W " (TEAM)" Q
I PSGAPS?.E1C.E S PSGAPS="" W $C(7)," ??" Q
I PSGAPS?1."?" W !!?2,"Enter 'T' (or press RETURN) to sort and print patients by TEAM. Enter 'P'",!,"to sort and print patients by treating PROVIDER." S PSGAPS="" Q
F Q=1:1:$L(PSGAPS) I $E(PSGAPS,Q)?1L S PSGAPS=$E(PSGAPS,1,Q-1)_$C($A($E(PSGAPS,Q))-32)_$E(PSGAPS,Q+1,$L(PSGAPS))
F X="TEAM","PROVIDER" I $P(X,PSGAPS)="" W $P(X,PSGAPS,2) S PSGAPS=$E(X) Q
E W $C(7)," ??" S PSGAPS=""
Q
;
Q2 ;
W:'$T $C(7) S:'$T PSGAPO="^" Q:PSGAPO="^"
I PSGAPO="" S PSGAPO="A" W " (ALL)" Q
I PSGAPO?.E1C.E S PSGAPO="" W $C(7)," ??" Q
I PSGAPO?1."?" W !!?2,"Enter 'A' (or press RETURN) to print ALL ACTIVE orders for the patient(s)",!,"selected. Enter 'E' to print only orders that will EXPIRE within the date",!,"range selected for the patient(s) selected." S PSGAPO="" Q
F Q=1:1:$L(PSGAPO) I $E(PSGAPO,Q)?1L S PSGAPO=$E(PSGAPO,1,Q-1)_$C($A($E(PSGAPO,Q))-32)_$E(PSGAPO,Q+1,$L(PSGAPO))
F X="ALL","EXPIRING" I $P(X,PSGAPO)="" W $P(X,PSGAPO,2) S PSGAPO=$E(X) Q
E W $C(7)," ??" S PSGPAS=""
Q
ENLM ;Entry point for PSJ LM AP2 protocol
N PSJNEW,PSGPTMP,PPAGE S PSJNEW=1
S PSGPTMP=0,PPAGE=1
D ENCV^PSGSETU I $D(XQUIT) Q
S PSGPAT=PSGP,PSGPAT(DFN)="",(PSGAPWD,PSGAPWG)=0,(PSGAPWDN,PSGAPWGN)="",PSGSS="P",PSGAPS="T" D ORS1
S PSJNKF=1 G DONE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGCAP 4990 printed Sep 23, 2025@19:36:59 Page 2
PSGCAP ;BIR/CML3-ACTION PROFILE (#2) ;04 APR 96 / 1:10 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**111**;16 DEC 97
+2 NEW PSJNEW,PSGPTMP,PPAGE
SET PSJNEW=1
+3 ;
+4 DO ENCV^PSGSETU
IF $DATA(XQUIT)
QUIT
+5 ;
START ;
+1 SET (PSGAP,PSGP,PSGAPWD,PSGAPWG)=0
SET (PSGAPWDN,PSGAPWGN)=""
SET PSGSSH="AP"
SET PSGPTMP=0
SET PPAGE=1
+2 DO ^PSGSEL
if PSGSS="^"!(PSGSS="")
GOTO DONE
DO @PSGSS
IF (Y'="^OTHER")
IF (Y'>0)
WRITE !!?3,"No patient(s) selected. Option terminated."
GOTO START
+3 ;
ORS IF '$GET(PSGAPWG)
SET PSGAPS="P"
GOTO ORS1
+1 SET PSGAPS="T"
IF $SELECT(PSGSS'="P":1,1:PSGPAT>1)
FOR
WRITE !!,"Sort Action Profiles by (T)eam or Treating (P)rovider? T// "
READ PSGAPS:DTIME
DO Q1
if PSGAPS]""
QUIT
ORS1 if PSGAPS="^"
GOTO START
DO NOW^%DTC
SET PSGDT=%
FOR N="START","STOP"
DO GDT
if $DATA(DIRUT)
GOTO START
+1 FOR
WRITE !!,"Print (A)ll active orders, or (E)xpiring orders only? A// "
READ PSGAPO:DTIME
DO Q2
if PSGAPO]""
QUIT
+2 if PSGAPO="^"
GOTO START
+3 if $$MEDTYPE^PSJMDIR($GET(PSGWD))
GOTO START
SET PSGMTYPE=Y
+4 KILL ZTSAVE
FOR X="PSGAPS","PSGAPO","PSGAPSD","PSGAPFD","PSGMTYPE","PSGP","PSGSS","PSGAPWD","PSGAPWG","PSGAPWDN","PSGAPWGN","PSGPAT(","PSGPTMP","PPAGE"
SET ZTSAVE(X)=""
+5 SET PSGTIR="ENQ^PSGCAP0"
SET ZTDESC="ACTION PROFILE"
DO ENDEV^PSGTI
if POP
GOTO START
if $DATA(IO("Q"))
GOTO DONE
+6 WRITE !,"...this may take a few minutes...(you really should QUEUE this report)..."
DO ENQ^PSGCAP0
+7 ;
+8 ;
DONE ;
+1 DO ENKV^PSGSETU
KILL CA,CNTR,DIAG,DO,DRG,FD,LQ,N,NF,ND,ND2,PSJJORD,PAGE,PDOB,PN,PND,PSEX,PSGAP,PSGAPWD,PSGAPWDN,PSGAPWG,PSGAPWGN,PSGDICA,PSGPAT,PSGSS
+2 KILL PSGSSH,RB,RTE,SD,SI,SM,ST,STRT,STP,STT,WS,WT,S1,ZTOUT,PSGAPFD,PSGAPSD,PSGAPS,PSGAPO,PSJACNWP,PSJDLW,PSJOPC,PSJPWDO,PSGWD
+3 KILL PSGADR,PSGALG,PSGEXPDT,PSGMTYPE,PSJSI,PSJSTOP,PSJTEAM,PST,QST
+4 KILL ^TMP($JOB)
+5 QUIT
+6 ;
GDT ;
+1 KILL DIR
NEW MINDT
if N="START"
SET MINDT=PSGDT-.0001
SET DIR("B")="NOW"
if N="STOP"
SET MINDT=PSGAPSD
SET DIR("B")=$$ENDD^PSGMI(PSGAPSD)
+2 SET DIR(0)="DA^"_MINDT_":9999999.9999:EFTX"
SET DIR("?")="^D DTM^PSGCAP"
SET DIR("A")="Enter "_$SELECT(N["R":"START",1:"STOP")_" date/time: "
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+3 IF X'="^"
if N["R"
SET PSGAPSD=$SELECT(Y'>0:PSGDT,Y#1:+$EXTRACT(Y,1,12),1:Y+.0001)
if N["O"
SET PSGAPFD=$SELECT(Y'>0:9999999,Y#1:+$EXTRACT(Y,1,12),1:Y+.24)
+4 QUIT
+5 ;
G ; get ward group
+1 SET DIC="^PS(57.5,"
SET DIC(0)="QEAMZ"
SET DIC("A")="Select WARD GROUP: "
WRITE !
DO ^DIC
KILL DIC
if Y>0
SET PSGAPWG=+Y
SET PSGAPWGN=Y(0,0)
IF Y<0
IF X="^OTHER"
Begin DoDot:1
+2 SET (Y,PSGAPWG,PSGAPWGN)="^OTHER"
SET (PSGAPWD,PSGAPWDN)="zz"
End DoDot:1
+3 QUIT
+4 ;
C ;
+1 KILL DIR
SET DIR(0)="FAO"
SET DIR("A")="Select CLINIC: "
+2 SET DIR("?")="^D CDIC^PSGVBW"
WRITE !
DO ^DIR
CDIC ;
+1 KILL DIC
SET DIC="^SC("
SET DIC(0)="QEMIZ"
DO ^DIC
KILL DIC
if +Y>0
SET CL=+Y
+2 if X["?"
WRITE !!,"Enter the clinic you want to use to select patients for processing.",!
+3 QUIT
L ;
+1 KILL DIR
SET DIR(0)="FAO"
SET DIR("A")="Select CLINIC GROUP: "
+2 SET DIR("?")="^D LDIC^PSGVBW"
WRITE !
DO ^DIR
LDIC ;
+1 KILL DIC
SET DIC="^PS(57.8,"
SET DIC(0)="QEMI"
DO ^DIC
KILL DIC
if +Y>0
SET CG=+Y
+2 if X["?"
WRITE !!,"Enter the name of the clinic group you want to use to select patients for processing."
+3 QUIT
W ; get ward
+1 SET DIC="^DIC(42,"
SET DIC(0)="QEAMZ"
SET DIC("A")="Select WARD: "
WRITE !
DO ^DIC
KILL DIC
if Y>0
SET (PSGWD,PSGAPWD)=+Y
SET PSGAPWDN=Y(0,0)
QUIT
+2 ;
P ; get patient
+1 KILL PSGPAT,PSJPWDO,PSGWD
+2 SET PSGPAT=0
FOR CNTR=1:1
if CNTR>1
SET PSGDICA="another"
DO ENP^PSGGAO
if PSGP'>0
QUIT
SET PSGPAT(PSGP)=""
SET PSGPAT=PSGPAT+1
if '$GET(PSJPWDO)
SET (PSGWD,PSJPWDO)=PSJPWD
SET PSGWD=$SELECT('$GET(PSGWD):0,PSJPWDO=PSJPWD:PSJPWD,1:0)
+3 SET Y=$SELECT(PSGPAT:1,1:-1)
KILL PSGDICA
QUIT
+4 ;
DTM ;
+1 SET Y=PSGDT
DO D^DIQ
SET T=$PIECE(Y,"@",2)
SET Y=$PIECE(Y,",")
+2 WRITE !!?2,"Enter a ",N," date. If a time is not entered for the ",N," date, the",!,$SELECT(N["R":"beginning",1:"end")," of the day is assumed and used."
+3 WRITE !?2,"If you wish to enter a ",$SELECT(N["R":"start",1:"stop")," date of ",Y,", you must enter a TIME of day",!,"of ",T," or greater. Any date after ",Y," does not need time entered.",!
SET Y=-1
QUIT
+4 ;
Q1 ;
+1 if '$TEST
WRITE $CHAR(7)
if '$TEST
SET PSGAPS="^"
if PSGAPS="^"
QUIT
+2 IF PSGAPS=""
SET PSGAPS="T"
WRITE " (TEAM)"
QUIT
+3 IF PSGAPS?.E1C.E
SET PSGAPS=""
WRITE $CHAR(7)," ??"
QUIT
+4 IF PSGAPS?1."?"
WRITE !!?2,"Enter 'T' (or press RETURN) to sort and print patients by TEAM. Enter 'P'",!,"to sort and print patients by treating PROVIDER."
SET PSGAPS=""
QUIT
+5 FOR Q=1:1:$LENGTH(PSGAPS)
IF $EXTRACT(PSGAPS,Q)?1L
SET PSGAPS=$EXTRACT(PSGAPS,1,Q-1)_$CHAR($ASCII($EXTRACT(PSGAPS,Q))-32)_$EXTRACT(PSGAPS,Q+1,$LENGTH(PSGAPS))
+6 FOR X="TEAM","PROVIDER"
IF $PIECE(X,PSGAPS)=""
WRITE $PIECE(X,PSGAPS,2)
SET PSGAPS=$EXTRACT(X)
QUIT
+7 IF '$TEST
WRITE $CHAR(7)," ??"
SET PSGAPS=""
+8 QUIT
+9 ;
Q2 ;
+1 if '$TEST
WRITE $CHAR(7)
if '$TEST
SET PSGAPO="^"
if PSGAPO="^"
QUIT
+2 IF PSGAPO=""
SET PSGAPO="A"
WRITE " (ALL)"
QUIT
+3 IF PSGAPO?.E1C.E
SET PSGAPO=""
WRITE $CHAR(7)," ??"
QUIT
+4 IF PSGAPO?1."?"
WRITE !!?2,"Enter 'A' (or press RETURN) to print ALL ACTIVE orders for the patient(s)",!,"selected. Enter 'E' to print only orders that will EXPIRE within the date",!,"range selected for the patient(s) selected."
SET PSGAPO=""
QUIT
+5 FOR Q=1:1:$LENGTH(PSGAPO)
IF $EXTRACT(PSGAPO,Q)?1L
SET PSGAPO=$EXTRACT(PSGAPO,1,Q-1)_$CHAR($ASCII($EXTRACT(PSGAPO,Q))-32)_$EXTRACT(PSGAPO,Q+1,$LENGTH(PSGAPO))
+6 FOR X="ALL","EXPIRING"
IF $PIECE(X,PSGAPO)=""
WRITE $PIECE(X,PSGAPO,2)
SET PSGAPO=$EXTRACT(X)
QUIT
+7 IF '$TEST
WRITE $CHAR(7)," ??"
SET PSGPAS=""
+8 QUIT
ENLM ;Entry point for PSJ LM AP2 protocol
+1 NEW PSJNEW,PSGPTMP,PPAGE
SET PSJNEW=1
+2 SET PSGPTMP=0
SET PPAGE=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"
SET PSGAPS="T"
DO ORS1
+5 SET PSJNKF=1
GOTO DONE
