PSGAP0 ;BIR/CML3-ACTION PROFILE ;20 May 98 / 12:36 PM
;;5.0;INPATIENT MEDICATIONS;**8,58,111,278,275**;16 DEC 97;Build 157
;
; Reference to ^PS(55 is supported by DBIA# 2191
;
GOD ; gather order data
N PSJCLN,CLINSORT
S ND=$G(^PS(55,PSGP,5,PSJJORD,0)),ND2=$G(^(2)),SI=$P($G(^(6)),"^"),DRG=$G(^(.2)) ;WS=$S(DRG&PSGAPWD:$D(^PSI(58.1,"D",+DRG,PSGAPWD)),1:0),DRG=$G(^PS(50.7,+DRG,0))
;S NF=$P(DRG,"^",9)
S X=$$NFWS^PSJUTL1(PSGP,PSJJORD_"U",PSGAPWD) S NF=$P(X,U),WS=$P(X,U,2),SM=$S('$P(X,U,3):0,$P(X,U,4):1,1:2)
N X,PSG
D DRGDISP^PSJLMUT1(PSGP,PSJJORD_"U",40,0,.PSG,1)
S DRG=PSG(1),DRG=$S(DRG["NOT FOUND":"z",1:DRG)
S ST=$P(ND,"^",9),ND=$P(ND,"^",7),SD=$P(ND2,"^",2),FD=$P(ND2,"^",4)
I STP'=9999999\1,(SD>STP) Q
F X="SD","FD" S @X=$E($$ENDTC^PSGMI(@X),1,5)
;
S Y=SI S:Y]"" Y=$$ENSET^PSGSICHK(Y)
; PSJ*5*275 get clinic
S PSJCLN=$$CLINIC^PSJO1(PSGP,+PSJJORD_"U") I (PSJCLN]"") S PSGAWPDN="zz" S CLINSORT=$$CLINSORT^PSJO1($P(ND,"^",9))
S X=$S(($G(PSJCLN)]""):"zz"_U_PSJCLN_U_CLINSORT_U_$E(DRG,1,20),1:ND_U_$E(DRG,1,20))
;
S ^TMP($J,$E(PSGAPWDN,1,20),TM,PN,X,+PSJJORD)=ST_U_SD_U_FD_U_WS_U_SM_U_NF S:Y]"" ^(PSJJORD,1)=Y
Q
;
PAT ;
S RB=$G(^DPT(PSGP,.101)) S:RB]"" TM=$S('$D(PSGAPTM):"zz",1:$O(^PS(57.7,"AWRT",PSGAPWD,RB,0))) S:$G(TM)="" TM="zz" I PSGAPWDN="" S PSGAPWDN="* NF *"
I $D(PSGAPTM) S ATM="",ATM=$O(PSGAPTM(ATM)) I ATM'="ALL" Q:'$D(PSGAPTM(+TM))
S:TM'="zz" TM=^PS(57.7,PSGAPWD,1,TM,0)
S PSJACNWP=1 D PSJAC2^PSJAC(1),NOW^%DTC S PSGDT=%,PND=PSGP(0),PN=$S($G(PSJSEL("RBP"))="R":RB,1:"")_"^"_$E($P(PND,"^"),1,20)_"^"_PSGP
I '$G(STT) S STT=PSGDT,STP=9999999
S:PSGMTYPE[1 PSGMTYPE="2,3,4,5,6"
I PSGMTYPE[2 D
. F STRT=STT:0 S STRT=$O(^PS(55,PSGP,5,"AUS",STRT)) Q:'STRT F PSJJORD=0:0 S PSJJORD=$O(^PS(55,PSGP,5,"AUS",STRT,PSJJORD)) Q:'PSJJORD D GOD
. S XTYPE=2,PST="S" D ^PSGAPIV
N XTYPE F XTYPE=3:1:6 I PSGMTYPE[XTYPE S PST=$S(XTYPE=3:"P",XTYPE=4:"A",XTYPE=5:"H",1:"C") D ^PSGAPIV
I PSGMTYPE[3 S XTYPE=3,PST="S" D ^PSGAPIV ;* Find syringe type iv
I $D(^TMP($J,$E(PSGAPWDN,1,20),TM,PN)) D
. S ^TMP($J,$E(PSGAPWDN,1,20),TM,PN)=$P(PSJPSEX,"^",2)_"^"_$E($P(PSJPDOB,"^",2),1,10)_";"_PSJPAGE_"^"_VA("PID")_"^"_PSJPDX_"^"_$S(PSJPRB]"":PSJPRB,1:"*NF*")_"^"_$E($P(PSJPAD,"^",2),1,10)_"^"_$E($P(PSJPTD,"^",2),1,10)_"^"_+PSJPWT
. S:($G(PSJSEL("WG"))="^OTHER") ^TMP("PSGAP0",$J,"OUTPT",PSGP)=""
Q
;
GDT ;
K %DT S %DT="EFTX",Y=-1,%DT(0)=$S(N["R":PSGDT,1:STT) F W !!,"Enter ",N," date/time: " R X:DTIME W:'$T $C(7) S:'$T X="^" Q:"^"[X D DTM:X?1."?",^%DT Q:Y>0
I X'="^" S:N["R" STT=$S(Y'>0:PSGDT,Y#1:+$E(Y,1,12),1:Y+.0002)-.0001 S:N["O" STP=$S(Y'>0:9999999,Y#1:+$E(Y,1,12),1:Y+.24)
K %DT Q
;
EN ; entry point
K ^TMP($J) ;PSJ*5*278
N CLIN,INDEX
I PSGSS'="P" D NOW^%DTC S PSGDT=%,DT=$$DT^XLFDT F N="START","STOP" D GDT I X="^" S PSJSTOP=1 Q
I PSGSS'="P" Q:X="^" S:'$P(STP,".",2) $P(STP,".",2)=24 S:'$P(STT,".",2) $P(STT,".",2)="0001"
S PSJSTOP=$$MEDTYPE^PSJMDIR($G(PSGWD)) Q:PSJSTOP S PSGMTYPE=Y
K ZTSAVE S:PSGSS'="P" (ZTSAVE("STT"),ZTSAVE("STP"))="" F X="PSGP","PSGSS","PSGAPWD","PSGAPWG","PSGAPWDN","PSGAPWGN","PSGPAT(","PSGAPTM(","PSGMTYPE","PSGPTMP","PSJSEL(","PSJOS","PPAGE" S ZTSAVE(X)=""
W !,"...this may take a few minutes...(you should QUEUE this report)..."
S PSGTIR="ENQ^PSGAP0",ZTDESC="ACTION PROFILE" D ENDEV^PSGTI S:POP PSJSTOP=1 Q:POP!$D(IO("Q"))
;
ENQ ; queued entry point
K ^TMP("PSGAP0",$J) N RB,ATM,TM,DRGI,DRGN,DRGT,ON,PST,PSIVUP,PSJORIFN,QST,SLS,XTYPE
D @("P"_PSGSS),^PSGAPP D ^%ZISC K ^TMP("PSGAP0",$J)
Q
;
PG ;
I $G(PSJSEL("WG"))="^OTHER" D CLIN Q
F PSGAPWD=0:0 S PSGAPWD=$O(^PS(57.5,"AC",PSGAPWG,PSGAPWD)) Q:'PSGAPWD I $D(^DIC(42,PSGAPWD,0)),$P(^(0),"^")]"" S PSGAPWDN=$P(^(0),"^") D PW
Q
;
CLIN ;
F INDEX="AIVC","AUDC" S STOP=0 F S STOP=$O(^PS(55,INDEX,STOP)) Q:'STOP S CLIN=0 F S CLIN=$O(^PS(55,INDEX,STOP,CLIN)) Q:'CLIN D
. S DFN=0 F S DFN=$O(^PS(55,INDEX,STOP,CLIN,DFN)) Q:'DFN I '$D(^TMP("PSGAP0",$J,"OUTPT",DFN)) D
.. S PSGP=DFN,Q=STOP N STOP D PAT
Q
;
PW ;
F PSGP=0:0 S PSGP=$O(^DPT("CN",PSGAPWDN,PSGP)) Q:'PSGP D
.S Q=$O(^PS(55,PSGP,5,"AUS",STT)) I Q D PAT Q
.S Q=$O(^PS(55,PSGP,"IV","AIS",STT)) I Q D PAT
Q
;
PP ;
F PSGP=0:0 S PSGP=$O(PSGPAT(PSGP)) Q:'PSGP S PSGAPWDN=$P($G(^DPT(PSGP,.1)),"^") S:PSGAPWDN]"" PSGAPWD=+$O(^DIC(42,"B",PSGAPWDN,0)) D PAT
Q
;
DTM ;
N T
S Y=%DT(0) D D^DIQ S T=$P(Y,"@",2),Y=$P(Y,",")
W !!?2,"If a ",N," date is entered, an action profile will print for only those",!,"patients that have at least one active order with a ",$S(N["A":"STOP",1:"START")," DATE on or ",$S(N["A":"after",1:"before"),!,"the ",N," date entered."
W !?2,"Entry is not required. If neither date is entered, all patients with active",!,"orders will print (for the ward(s) chosen). Enter an up-arrow (^) to exit."
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGAP0 4997 printed Sep 23, 2025@19:36:53 Page 2
PSGAP0 ;BIR/CML3-ACTION PROFILE ;20 May 98 / 12:36 PM
+1 ;;5.0;INPATIENT MEDICATIONS;**8,58,111,278,275**;16 DEC 97;Build 157
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA# 2191
+4 ;
GOD ; gather order data
+1 NEW PSJCLN,CLINSORT
+2 ;WS=$S(DRG&PSGAPWD:$D(^PSI(58.1,"D",+DRG,PSGAPWD)),1:0),DRG=$G(^PS(50.7,+DRG,0))
SET ND=$GET(^PS(55,PSGP,5,PSJJORD,0))
SET ND2=$GET(^(2))
SET SI=$PIECE($GET(^(6)),"^")
SET DRG=$GET(^(.2))
+3 ;S NF=$P(DRG,"^",9)
+4 SET X=$$NFWS^PSJUTL1(PSGP,PSJJORD_"U",PSGAPWD)
SET NF=$PIECE(X,U)
SET WS=$PIECE(X,U,2)
SET SM=$SELECT('$PIECE(X,U,3):0,$PIECE(X,U,4):1,1:2)
+5 NEW X,PSG
+6 DO DRGDISP^PSJLMUT1(PSGP,PSJJORD_"U",40,0,.PSG,1)
+7 SET DRG=PSG(1)
SET DRG=$SELECT(DRG["NOT FOUND":"z",1:DRG)
+8 SET ST=$PIECE(ND,"^",9)
SET ND=$PIECE(ND,"^",7)
SET SD=$PIECE(ND2,"^",2)
SET FD=$PIECE(ND2,"^",4)
+9 IF STP'=9999999\1
IF (SD>STP)
QUIT
+10 FOR X="SD","FD"
SET @X=$EXTRACT($$ENDTC^PSGMI(@X),1,5)
+11 ;
+12 SET Y=SI
if Y]""
SET Y=$$ENSET^PSGSICHK(Y)
+13 ; PSJ*5*275 get clinic
+14 SET PSJCLN=$$CLINIC^PSJO1(PSGP,+PSJJORD_"U")
IF (PSJCLN]"")
SET PSGAWPDN="zz"
SET CLINSORT=$$CLINSORT^PSJO1($PIECE(ND,"^",9))
+15 SET X=$SELECT(($GET(PSJCLN)]""):"zz"_U_PSJCLN_U_CLINSORT_U_$EXTRACT(DRG,1,20),1:ND_U_$EXTRACT(DRG,1,20))
+16 ;
+17 SET ^TMP($JOB,$EXTRACT(PSGAPWDN,1,20),TM,PN,X,+PSJJORD)=ST_U_SD_U_FD_U_WS_U_SM_U_NF
if Y]""
SET ^(PSJJORD,1)=Y
+18 QUIT
+19 ;
PAT ;
+1 SET RB=$GET(^DPT(PSGP,.101))
if RB]""
SET TM=$SELECT('$DATA(PSGAPTM):"zz",1:$ORDER(^PS(57.7,"AWRT",PSGAPWD,RB,0)))
if $GET(TM)=""
SET TM="zz"
IF PSGAPWDN=""
SET PSGAPWDN="* NF *"
+2 IF $DATA(PSGAPTM)
SET ATM=""
SET ATM=$ORDER(PSGAPTM(ATM))
IF ATM'="ALL"
if '$DATA(PSGAPTM(+TM))
QUIT
+3 if TM'="zz"
SET TM=^PS(57.7,PSGAPWD,1,TM,0)
+4 SET PSJACNWP=1
DO PSJAC2^PSJAC(1)
DO NOW^%DTC
SET PSGDT=%
SET PND=PSGP(0)
SET PN=$SELECT($GET(PSJSEL("RBP"))="R":RB,1:"")_"^"_$EXTRACT($PIECE(PND,"^"),1,20)_"^"_PSGP
+5 IF '$GET(STT)
SET STT=PSGDT
SET STP=9999999
+6 if PSGMTYPE[1
SET PSGMTYPE="2,3,4,5,6"
+7 IF PSGMTYPE[2
Begin DoDot:1
+8 FOR STRT=STT:0
SET STRT=$ORDER(^PS(55,PSGP,5,"AUS",STRT))
if 'STRT
QUIT
FOR PSJJORD=0:0
SET PSJJORD=$ORDER(^PS(55,PSGP,5,"AUS",STRT,PSJJORD))
if 'PSJJORD
QUIT
DO GOD
+9 SET XTYPE=2
SET PST="S"
DO ^PSGAPIV
End DoDot:1
+10 NEW XTYPE
FOR XTYPE=3:1:6
IF PSGMTYPE[XTYPE
SET PST=$SELECT(XTYPE=3:"P",XTYPE=4:"A",XTYPE=5:"H",1:"C")
DO ^PSGAPIV
+11 ;* Find syringe type iv
IF PSGMTYPE[3
SET XTYPE=3
SET PST="S"
DO ^PSGAPIV
+12 IF $DATA(^TMP($JOB,$EXTRACT(PSGAPWDN,1,20),TM,PN))
Begin DoDot:1
+13 SET ^TMP($JOB,$EXTRACT(PSGAPWDN,1,20),TM,PN)=$PIECE(PSJPSEX,"^",2)_"^"_$EXTRACT($PIECE(PSJPDOB,"^",2),1,10)_";"_PSJPAGE_"^"_VA("PID")_"^"_PSJPDX_"^"_...
... $SELECT(PSJPRB]"":PSJPRB,1:"*NF*")_"^"_$EXTRACT($PIECE(PSJPAD,"^",2),1,10)_"^"_$EXTRACT($PIECE(PSJPTD,"^",2),1,10)_"^"_+PSJPWT
+14 if ($GET(PSJSEL("WG"))="^OTHER")
SET ^TMP("PSGAP0",$JOB,"OUTPT",PSGP)=""
End DoDot:1
+15 QUIT
+16 ;
GDT ;
+1 KILL %DT
SET %DT="EFTX"
SET Y=-1
SET %DT(0)=$SELECT(N["R":PSGDT,1:STT)
FOR
WRITE !!,"Enter ",N," date/time: "
READ X:DTIME
if '$TEST
WRITE $CHAR(7)
if '$TEST
SET X="^"
if "^"[X
QUIT
if X?1."?"
DO DTM
DO ^%DT
if Y>0
QUIT
+2 IF X'="^"
if N["R"
SET STT=$SELECT(Y'>0:PSGDT,Y#1:+$EXTRACT(Y,1,12),1:Y+.0002)-.0001
if N["O"
SET STP=$SELECT(Y'>0:9999999,Y#1:+$EXTRACT(Y,1,12),1:Y+.24)
+3 KILL %DT
QUIT
+4 ;
EN ; entry point
+1 ;PSJ*5*278
KILL ^TMP($JOB)
+2 NEW CLIN,INDEX
+3 IF PSGSS'="P"
DO NOW^%DTC
SET PSGDT=%
SET DT=$$DT^XLFDT
FOR N="START","STOP"
DO GDT
IF X="^"
SET PSJSTOP=1
QUIT
+4 IF PSGSS'="P"
if X="^"
QUIT
if '$PIECE(STP,".",2)
SET $PIECE(STP,".",2)=24
if '$PIECE(STT,".",2)
SET $PIECE(STT,".",2)="0001"
+5 SET PSJSTOP=$$MEDTYPE^PSJMDIR($GET(PSGWD))
if PSJSTOP
QUIT
SET PSGMTYPE=Y
+6 KILL ZTSAVE
if PSGSS'="P"
SET (ZTSAVE("STT"),ZTSAVE("STP"))=""
FOR X="PSGP","PSGSS","PSGAPWD","PSGAPWG","PSGAPWDN","PSGAPWGN","PSGPAT(","PSGAPTM(","PSGMTYPE","PSGPTMP","PSJSEL(","PSJOS","PPAGE"
SET ZTSAVE(X)=""
+7 WRITE !,"...this may take a few minutes...(you should QUEUE this report)..."
+8 SET PSGTIR="ENQ^PSGAP0"
SET ZTDESC="ACTION PROFILE"
DO ENDEV^PSGTI
if POP
SET PSJSTOP=1
if POP!$DATA(IO("Q"))
QUIT
+9 ;
ENQ ; queued entry point
+1 KILL ^TMP("PSGAP0",$JOB)
NEW RB,ATM,TM,DRGI,DRGN,DRGT,ON,PST,PSIVUP,PSJORIFN,QST,SLS,XTYPE
+2 DO @("P"_PSGSS)
DO ^PSGAPP
DO ^%ZISC
KILL ^TMP("PSGAP0",$JOB)
+3 QUIT
+4 ;
PG ;
+1 IF $GET(PSJSEL("WG"))="^OTHER"
DO CLIN
QUIT
+2 FOR PSGAPWD=0:0
SET PSGAPWD=$ORDER(^PS(57.5,"AC",PSGAPWG,PSGAPWD))
if 'PSGAPWD
QUIT
IF $DATA(^DIC(42,PSGAPWD,0))
IF $PIECE(^(0),"^")]""
SET PSGAPWDN=$PIECE(^(0),"^")
DO PW
+3 QUIT
+4 ;
CLIN ;
+1 FOR INDEX="AIVC","AUDC"
SET STOP=0
FOR
SET STOP=$ORDER(^PS(55,INDEX,STOP))
if 'STOP
QUIT
SET CLIN=0
FOR
SET CLIN=$ORDER(^PS(55,INDEX,STOP,CLIN))
if 'CLIN
QUIT
Begin DoDot:1
+2 SET DFN=0
FOR
SET DFN=$ORDER(^PS(55,INDEX,STOP,CLIN,DFN))
if 'DFN
QUIT
IF '$DATA(^TMP("PSGAP0",$JOB,"OUTPT",DFN))
Begin DoDot:2
+3 SET PSGP=DFN
SET Q=STOP
NEW STOP
DO PAT
End DoDot:2
End DoDot:1
+4 QUIT
+5 ;
PW ;
+1 FOR PSGP=0:0
SET PSGP=$ORDER(^DPT("CN",PSGAPWDN,PSGP))
if 'PSGP
QUIT
Begin DoDot:1
+2 SET Q=$ORDER(^PS(55,PSGP,5,"AUS",STT))
IF Q
DO PAT
QUIT
+3 SET Q=$ORDER(^PS(55,PSGP,"IV","AIS",STT))
IF Q
DO PAT
End DoDot:1
+4 QUIT
+5 ;
PP ;
+1 FOR PSGP=0:0
SET PSGP=$ORDER(PSGPAT(PSGP))
if 'PSGP
QUIT
SET PSGAPWDN=$PIECE($GET(^DPT(PSGP,.1)),"^")
if PSGAPWDN]""
SET PSGAPWD=+$ORDER(^DIC(42,"B",PSGAPWDN,0))
DO PAT
+2 QUIT
+3 ;
DTM ;
+1 NEW T
+2 SET Y=%DT(0)
DO D^DIQ
SET T=$PIECE(Y,"@",2)
SET Y=$PIECE(Y,",")
+3 WRITE !!?2,"If a ",N," date is entered, an action profile will print for only those",!,"patients that have at least one active order with a ",$SELECT(N["A":"STOP",1:"START")," DATE on or ",$SELECT(N["A":"after",1:"before"),!,"the ",N," date ent
ered."
+4 WRITE !?2,"Entry is not required. If neither date is entered, all patients with active",!,"orders will print (for the ward(s) chosen). Enter an up-arrow (^) to exit."
+5 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
