PSGCAP0 ;BIR/CML3-ACTION PROFILE ;12 Mar 98 / 9:30 AM
;;5.0;INPATIENT MEDICATIONS;**8,58,111,149,275,301**;16 DEC 97;Build 3
;
; Reference to ^PS(55 is supported by DBIA# 2191
; Reference to ^PSDRUG is supported by DBIA# 2192
;
GOD ; gather order data
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)
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",20,0,.PSG,1)
S DRG=PSG(1),DRG=$S(DRG["NOT FOUND":"z",1:DRG) ;SM=$S('$P(ND,"^",5):0,$P(ND,"^",6):1,1:2)
S ST=$S($P(ND,U,27)="R"&($P(ND,U,9)="A"):"R",1:$P(ND,U,9)),ND=$P(ND,"^",7)
N DDRG S (X,DCU)=0 F S X=$O(^PS(55,PSGP,5,PSJJORD,1,X)) Q:'X S DDRG=^(X,0),DCU=DCU+($P($G(^PSDRUG(+DDRG,660)),"^",6)*($S($P(DDRG,"^",2):$P(DDRG,"^",2),1:1)))
;
; PSJ*5*275 get clinic
;S PSGAPWDN="zz"
N PSJCLN,CLINSORT S PSJCLN=$$CLINIC^PSJO1(PSGP,PSJJORD_"U")
; When run by Clinic, if patient also has Inpatient orders, make sure those orders have a corresponding patient node in ^TMP
I PSJCLN="",($G(PSGSS)["C"),$G(PSJPWD),($G(PSJPWDN)]"") N PSGAPWDN,PSGAPWD S PSGAPWD=PSJPWD,PSGAPWDN=PSJPWDN D
.S ^TMP($J,S1,PSGAPWDN,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)
.S ^TMP($J,S1,PSGAPWDN,PN)=^(PN)_"^"_PSJPWT_"^"_PSJPWTD_"^"_PSJPHT_"^"_PSJPHTD_"^"_$P(PSGP(0),"^")
I (PSJCLN]"") S CLINSORT=$$CLINSORT^PSJO1($G(ST)) I CLINSORT N:($G(PSGSS)'["C") PSGAPWDN S PSGAPWDN="zz"_U_PSJCLN_U_CLINSORT_U_ST
;
S SD=$P(ND2,"^",2),FD=$P(ND2,"^",4) F X="SD","FD" S @X=$E($$ENDTC^PSGMI(@X),1,5)
;
S Y=SI S:Y]"" Y=$$ENSET^PSGSICHK(Y)
S PSGAPWDN=$S($P($G(PSGAPWDN),"^")="zz"&($P($G(PSGAPWDN),"^",2)'=""):PSGAPWDN,$G(PSGAPWD)="zz":"zz",$G(PSGAPWDN):PSGAPWDN,'$G(PSGAPWDN)&($G(PSJPWDN)'=""):PSJPWDN,1:"zz")
S ^TMP($J,S1,PSGAPWDN,PN,ND_"^"_DRG,PSJJORD)=ST_"^"_SD_"^"_FD_"^"_WS_"^"_SM_"^"_NF_"^"_DCU_"^"_DRG S:Y]"" ^(PSJJORD,1)=Y Q
;
PAT ;
D PSJAC2^PSJAC(1),NOW^%DTC S PSGDT=%,PN=$E($P(PSGP(0),"^"),1,20)_"^"_PSGP
S S1="zz" I PSGAPS="T",PSJPWD,PSJPRB]"",$D(^PS(57.7,PSJPWD,1,+$O(^PS(57.7,"AWRT",PSJPWD,PSJPRB,0)),0)),$P(^(0),"^")]"" S S1=$P(^(0),"^")
I PSGAPS="P",PSJPTSP,$D(^VA(200,PSJPTSP,0)),$P(^(0),"^")]"" S S1=$P(^(0),"^")
S:PSGMTYPE[1 PSGMTYPE="2,3,4,5,6"
I PSGMTYPE[2 D
. F STRT=PSGAPSD-.0001:0 S STRT=$O(^PS(55,PSGP,5,"AUS",STRT)) Q:$S('STRT:1,PSGAPO="E":STRT>PSGAPFD,1:0) I STRT'=PSGAPSD F PSJJORD=0:0 S PSJJORD=$O(^PS(55,PSGP,5,"AUS",STRT,PSJJORD)) Q:'PSJJORD D GOD
. S XTYPE=2,PST="S" D ^PSGCAPIV
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 ^PSGCAPIV
I PSGMTYPE[3 S XTYPE=3,PST="S" D ^PSGCAPIV ;* Find syringe type iv
I $D(^TMP($J,S1,PSGAPWDN,PN)) S ^(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)
I S ^TMP($J,S1,PSGAPWDN,PN)=^(PN)_"^"_PSJPWT_"^"_PSJPWTD_"^"_PSJPHT_"^"_PSJPHTD_"^"_$P(PSGP(0),"^")
Q
;
ENQ ; queued entry point
N ALFLG,DCU,DRGI,DRGN,DRGT,KKA,HT,HTD,ON,PST,PSIVUP,PSJORIFN,QST,WTD,XTYPE
K ^TMP($J) S STT=PSGAPSD-.0001,PSJACNWP=1 D @("P"_PSGSS),^PSGCAPP D ^%ZISC
Q
;
PG ;
I PSGAPWD="zz" 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
;
PW ;
F PSGP=0:0 S PSGP=$O(^DPT("CN",PSGAPWDN,PSGP)) Q:'PSGP 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)) S:PSGAPWDN="" PSGAPWDN="zz" D PAT
Q
;
PL S CL="" F S CL=$O(^PS(57.8,"AD",CG,CL)) Q:CL="" D PC
Q
PC S PSGAPWDN=$S($D(^SC(CL,0)):$P(^(0),"^"),1:"")
S PSGP="" F S PSGP=$O(^PS(53.1,"AD",CL,PSGP)) Q:PSGP="" D PAT
N INDEX,APSTOP
F INDEX="AIVC","AUDC" S APSTOP=0 F S APSTOP=$O(^PS(55,INDEX,APSTOP)) Q:'APSTOP D
. S DFN=0 F S DFN=$O(^PS(55,INDEX,APSTOP,CL,DFN)) Q:'DFN I '$D(^TMP("PSGAP0",$J,"OUTPT",DFN)) S PSGP=DFN,Q=APSTOP,PSGAPWD="zz" D PAT
Q
CLIN ;
N INDEX,APSTOP,CLIN
F INDEX="AIVC","AUDC" S APSTOP=0 F S APSTOP=$O(^PS(55,INDEX,APSTOP)) Q:'APSTOP S CLIN=0 F S CLIN=$O(^PS(55,INDEX,APSTOP,CLIN)) Q:'CLIN D
. S DFN=0 F S DFN=$O(^PS(55,INDEX,APSTOP,CLIN,DFN)) Q:'DFN I '$D(^TMP("PSGAP0",$J,"OUTPT",DFN)) S PSGP=DFN,Q=APSTOP,PSGAPWD="zz" D PAT
Q
;
SETPI(PSGP) ; Set Patient Information for clinic orders when run by Ward
N PSJCLPIN D PSJAC2^PSJAC(1)
S PSJCLPIN=$P($G(PSJPSEX),"^",2)_"^"_$E($P($G(PSJPDOB),"^",2),1,10)_";"_$G(PSJPAGE)_"^"_$G(VA("PID"))_"^"_$G(PSJPDX)_"^"_$S($G(PSJPRB)]"":$G(PSJPRB),1:"*NF*")
Q PSJCLPIN_"^"_$E($P($G(PSJPAD),"^",2),1,10)_"^"_$E($P(PSJPTD,"^",2),1,10)_"^"_PSJPWT_"^"_PSJPWTD_"^"_PSJPHT_"^"_PSJPHTD_"^"_$P(PSGP(0),"^")
ENOR ;
D ENCV^PSGSETU I $D(XQUIT) Q
S (DFN,PSGP)=+ORVP D ^PSJAC S PSGPAT=PSGP,PSGPAT(DFN)="",(PSGAP,PSGAPWD,PSGAPWG)=0,(PSGAPWDN,PSGAPWGN)="",PSGSS="P" D ORS^PSGCAP S PSJNKF=1 D DONE^PSGCAP Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGCAP0 5203 printed Sep 23, 2025@19:37 Page 2
PSGCAP0 ;BIR/CML3-ACTION PROFILE ;12 Mar 98 / 9:30 AM
+1 ;;5.0;INPATIENT MEDICATIONS;**8,58,111,149,275,301**;16 DEC 97;Build 3
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA# 2191
+4 ; Reference to ^PSDRUG is supported by DBIA# 2192
+5 ;
GOD ; gather order data
+1 ;WS=$S(DRG&PSGAPWD:$D(^PSI(58.1,"D",+DRG,PSGAPWD)),1:0)
SET ND=$GET(^PS(55,PSGP,5,PSJJORD,0))
SET ND2=$GET(^(2))
SET SI=$PIECE($GET(^(6)),"^")
SET DRG=$GET(^(.2))
+2 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)
+3 NEW X,PSG
+4 DO DRGDISP^PSJLMUT1(PSGP,PSJJORD_"U",20,0,.PSG,1)
+5 ;SM=$S('$P(ND,"^",5):0,$P(ND,"^",6):1,1:2)
SET DRG=PSG(1)
SET DRG=$SELECT(DRG["NOT FOUND":"z",1:DRG)
+6 SET ST=$SELECT($PIECE(ND,U,27)="R"&($PIECE(ND,U,9)="A"):"R",1:$PIECE(ND,U,9))
SET ND=$PIECE(ND,"^",7)
+7 NEW DDRG
SET (X,DCU)=0
FOR
SET X=$ORDER(^PS(55,PSGP,5,PSJJORD,1,X))
if 'X
QUIT
SET DDRG=^(X,0)
SET DCU=DCU+($PIECE($GET(^PSDRUG(+DDRG,660)),"^",6)*($SELECT($PIECE(DDRG,"^",2):$PIECE(DDRG,"^",2),1:1)))
+8 ;
+9 ; PSJ*5*275 get clinic
+10 ;S PSGAPWDN="zz"
+11 NEW PSJCLN,CLINSORT
SET PSJCLN=$$CLINIC^PSJO1(PSGP,PSJJORD_"U")
+12 ; When run by Clinic, if patient also has Inpatient orders, make sure those orders have a corresponding patient node in ^TMP
+13 IF PSJCLN=""
IF ($GET(PSGSS)["C")
IF $GET(PSJPWD)
IF ($GET(PSJPWDN)]"")
NEW PSGAPWDN,PSGAPWD
SET PSGAPWD=PSJPWD
SET PSGAPWDN=PSJPWDN
Begin DoDot:1
+14 SET ^TMP($JOB,S1,PSGAPWDN,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($P
IECE(PSJPTD,"^",2),1,10)
+15 SET ^TMP($JOB,S1,PSGAPWDN,PN)=^(PN)_"^"_PSJPWT_"^"_PSJPWTD_"^"_PSJPHT_"^"_PSJPHTD_"^"_$PIECE(PSGP(0),"^")
End DoDot:1
+16 IF (PSJCLN]"")
SET CLINSORT=$$CLINSORT^PSJO1($GET(ST))
IF CLINSORT
if ($GET(PSGSS)'["C")
NEW PSGAPWDN
SET PSGAPWDN="zz"_U_PSJCLN_U_CLINSORT_U_ST
+17 ;
+18 SET SD=$PIECE(ND2,"^",2)
SET FD=$PIECE(ND2,"^",4)
FOR X="SD","FD"
SET @X=$EXTRACT($$ENDTC^PSGMI(@X),1,5)
+19 ;
+20 SET Y=SI
if Y]""
SET Y=$$ENSET^PSGSICHK(Y)
+21 SET PSGAPWDN=$SELECT($PIECE($GET(PSGAPWDN),"^")="zz"&($PIECE($GET(PSGAPWDN),"^",2)'=""):PSGAPWDN,$GET(PSGAPWD)="zz":"zz",$GET(PSGAPWDN):PSGAPWDN,'$GET(PSGAPWDN)&($GET(PSJPWDN)'=""):PSJPWDN,1:"zz")
+22 SET ^TMP($JOB,S1,PSGAPWDN,PN,ND_"^"_DRG,PSJJORD)=ST_"^"_SD_"^"_FD_"^"_WS_"^"_SM_"^"_NF_"^"_DCU_"^"_DRG
if Y]""
SET ^(PSJJORD,1)=Y
QUIT
+23 ;
PAT ;
+1 DO PSJAC2^PSJAC(1)
DO NOW^%DTC
SET PSGDT=%
SET PN=$EXTRACT($PIECE(PSGP(0),"^"),1,20)_"^"_PSGP
+2 SET S1="zz"
IF PSGAPS="T"
IF PSJPWD
IF PSJPRB]""
IF $DATA(^PS(57.7,PSJPWD,1,+$ORDER(^PS(57.7,"AWRT",PSJPWD,PSJPRB,0)),0))
IF $PIECE(^(0),"^")]""
SET S1=$PIECE(^(0),"^")
+3 IF PSGAPS="P"
IF PSJPTSP
IF $DATA(^VA(200,PSJPTSP,0))
IF $PIECE(^(0),"^")]""
SET S1=$PIECE(^(0),"^")
+4 if PSGMTYPE[1
SET PSGMTYPE="2,3,4,5,6"
+5 IF PSGMTYPE[2
Begin DoDot:1
+6 FOR STRT=PSGAPSD-.0001:0
SET STRT=$ORDER(^PS(55,PSGP,5,"AUS",STRT))
if $SELECT('STRT
QUIT
IF STRT'=PSGAPSD
FOR PSJJORD=0:0
SET PSJJORD=$ORDER(^PS(55,PSGP,5,"AUS",STRT,PSJJORD))
if 'PSJJORD
QUIT
DO GOD
+7 SET XTYPE=2
SET PST="S"
DO ^PSGCAPIV
End DoDot:1
+8 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 ^PSGCAPIV
+9 ;* Find syringe type iv
IF PSGMTYPE[3
SET XTYPE=3
SET PST="S"
DO ^PSGCAPIV
+10 IF $DATA(^TMP($JOB,S1,PSGAPWDN,PN))
SET ^(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)
+11 IF $TEST
SET ^TMP($JOB,S1,PSGAPWDN,PN)=^(PN)_"^"_PSJPWT_"^"_PSJPWTD_"^"_PSJPHT_"^"_PSJPHTD_"^"_$PIECE(PSGP(0),"^")
+12 QUIT
+13 ;
ENQ ; queued entry point
+1 NEW ALFLG,DCU,DRGI,DRGN,DRGT,KKA,HT,HTD,ON,PST,PSIVUP,PSJORIFN,QST,WTD,XTYPE
+2 KILL ^TMP($JOB)
SET STT=PSGAPSD-.0001
SET PSJACNWP=1
DO @("P"_PSGSS)
DO ^PSGCAPP
DO ^%ZISC
+3 QUIT
+4 ;
PG ;
+1 IF PSGAPWD="zz"
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 ;
PW ;
+1 FOR PSGP=0:0
SET PSGP=$ORDER(^DPT("CN",PSGAPWDN,PSGP))
if 'PSGP
QUIT
DO PAT
+2 QUIT
+3 ;
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))
if PSGAPWDN=""
SET PSGAPWDN="zz"
DO PAT
+2 QUIT
+3 ;
PL SET CL=""
FOR
SET CL=$ORDER(^PS(57.8,"AD",CG,CL))
if CL=""
QUIT
DO PC
+1 QUIT
PC SET PSGAPWDN=$SELECT($DATA(^SC(CL,0)):$PIECE(^(0),"^"),1:"")
+1 SET PSGP=""
FOR
SET PSGP=$ORDER(^PS(53.1,"AD",CL,PSGP))
if PSGP=""
QUIT
DO PAT
+2 NEW INDEX,APSTOP
+3 FOR INDEX="AIVC","AUDC"
SET APSTOP=0
FOR
SET APSTOP=$ORDER(^PS(55,INDEX,APSTOP))
if 'APSTOP
QUIT
Begin DoDot:1
+4 SET DFN=0
FOR
SET DFN=$ORDER(^PS(55,INDEX,APSTOP,CL,DFN))
if 'DFN
QUIT
IF '$DATA(^TMP("PSGAP0",$JOB,"OUTPT",DFN))
SET PSGP=DFN
SET Q=APSTOP
SET PSGAPWD="zz"
DO PAT
End DoDot:1
+5 QUIT
CLIN ;
+1 NEW INDEX,APSTOP,CLIN
+2 FOR INDEX="AIVC","AUDC"
SET APSTOP=0
FOR
SET APSTOP=$ORDER(^PS(55,INDEX,APSTOP))
if 'APSTOP
QUIT
SET CLIN=0
FOR
SET CLIN=$ORDER(^PS(55,INDEX,APSTOP,CLIN))
if 'CLIN
QUIT
Begin DoDot:1
+3 SET DFN=0
FOR
SET DFN=$ORDER(^PS(55,INDEX,APSTOP,CLIN,DFN))
if 'DFN
QUIT
IF '$DATA(^TMP("PSGAP0",$JOB,"OUTPT",DFN))
SET PSGP=DFN
SET Q=APSTOP
SET PSGAPWD="zz"
DO PAT
End DoDot:1
+4 QUIT
+5 ;
SETPI(PSGP) ; Set Patient Information for clinic orders when run by Ward
+1 NEW PSJCLPIN
DO PSJAC2^PSJAC(1)
+2 SET PSJCLPIN=$PIECE($GET(PSJPSEX),"^",2)_"^"_$EXTRACT($PIECE($GET(PSJPDOB),"^",2),1,10)_";"_$GET(PSJPAGE)_"^"_$GET(VA("PID"))_"^"_$GET(PSJPDX)_"^"_$SELECT($GET(PSJPRB)]"":$GET(PSJPRB),1:"*NF*")
+3 QUIT PSJCLPIN_"^"_$EXTRACT($PIECE($GET(PSJPAD),"^",2),1,10)_"^"_$EXTRACT($PIECE(PSJPTD,"^",2),1,10)_"^"_PSJPWT_"^"_PSJPWTD_"^"_PSJPHT_"^"_PSJPHTD_"^"_$PIECE(PSGP(0),"^")
ENOR ;
+1 DO ENCV^PSGSETU
IF $DATA(XQUIT)
QUIT
+2 SET (DFN,PSGP)=+ORVP
DO ^PSJAC
SET PSGPAT=PSGP
SET PSGPAT(DFN)=""
SET (PSGAP,PSGAPWD,PSGAPWG)=0
SET (PSGAPWDN,PSGAPWGN)=""
SET PSGSS="P"
DO ORS^PSGCAP
SET PSJNKF=1
DO DONE^PSGCAP
QUIT
