PSIVSTAT ;BIR/PR-BUILD COST TRANS NODE, ENTER COMPILE ;6 Nov 98 / 4:45 PM
;;5.0;INPATIENT MEDICATIONS ;**3,18,84,81,104,111,130,199,345**;16 DEC 97;Build 1
;
; Reference to ^ECXPIV1 is supported by DBIA# 1882.
; Reference to ^PS(52.6 is supported by DBIA# 1231.
; Reference to ^PS(52.7 is supported by DBIA# 2173.
; Reference to ^PS(55 is supported by DBIA# 2191.
;
;Needs dfn,on,psivnol,psivc (optional:dis/ret/des).
;
S PSIVV=1 L +^PS(50.8,PSIVSN):5000
I '$G(PSIVC) S PSIVC=$S(($G(PSJRDC)="R"):2,($G(PSJRDC)="D"):3,($G(PSJRDC)]""):4,1:1)
;D NOW^%DTC S (Y,PSIVNOW)=% I '$D(^PS(50.8,PSIVSN,0)) L +^PS(50.8,0) S ^PS(50.8,PSIVSN,0)=PSIVSN,$P(^(0),U,3,4)=PSIVSN_U_($P(^PS(50.8,0),U,4)+1) L -^PS(50.8,0)
D NOW^%DTC S (Y,PSIVNOW)=% I '$D(^PS(50.8,PSIVSN,0)) D S ^PS(50.8,PSIVSN,0)=PSIVSN,$P(^(0),U,3,4)=PSIVSN_U_($P(^PS(50.8,0),U,4)+1) L -^PS(50.8,0)
.F L +^PS(50.8,0):1 Q:$T
S $P(^PS(50.8,PSIVSN,1,0),U,1,3)="^50.801P^"_DFN S:'$D(^(DFN,0)) ^(0)=DFN,$P(^(0),U,3,4)=DFN_U_($P(^PS(50.8,PSIVSN,1,0),U,4)+1)
S PSIVTN=1 I $D(^PS(50.8,PSIVSN,1,DFN,1,0)) F PSIVTN=$P(^(0),U,3)+1:1 Q:'$D(^PS(50.8,PSIVSN,1,DFN,1,PSIVTN,0))
;
RETDET ;Get the ward that returns or destroyed need to be associated with.
;RDFLAG & RDWARD ARE set in routine PSIVRD.
I $D(RDFLAG) S PSIVWD=RDWARD S:'$D(^PS(55,DFN,"IV",+ON,9)) $P(^(9),U,1,2)="" S $P(^(9),U,3)=$P(^(9),U,3)-PSIVNOL G SKIP
;
LBWD ;Get the ward we that we are printing labels on.
S PSIVWD=$P(^PS(55,DFN,"IV",+ON,0),U,22) G:PSIVWD SKIP
S PSIVWD=$S($D(^DPT(DFN,.1)):$O(^DIC(42,"B",^DPT(DFN,.1),0)),1:.5)
;
SKIP ;
;Set up the transaction node here.
S ^PS(50.8,PSIVSN,1,DFN,1,0)="^50.802^"_PSIVTN_U_PSIVTN,^(PSIVTN,0)=PSIVTN_U_+ON_U_PSIVC_U_PSIVNOW_U_PSIVNOL_U_PSIVWD
;
DSS ; Update DSS for IV extract
;
S X="ECXPIV1" X ^%ZOSF("TEST") Q:'$T
N ADSTR,ADUNITS,DCST,DDRG,DRG,PROV,SOLSTR,TYP,START,IVROOM,DSDATE,A,B
K ^TMP($J)
S X=$G(^PS(55,DFN,"IV",+ON,0)),PROV=$P(X,U,6),TYP=$P(X,U,4),START=$P(X,U,2)
S A=$G(^PS(55,DFN,"IV",+ON,2)),IVROOM=$P(A,"^",2),B=$G(^PS(55,DFN,"IV",+ON,4)),DSDATE=$S($P(B,"^",2)]"":$P(B,"^",2),1:$P(A,"^"))
F DRGTYP="AD","SOL" F DRG=0:0 S DRG=$O(^PS(55,DFN,"IV",+ON,DRGTYP,DRG)) Q:'DRG D
.S ND=$G(^PS(55,DFN,"IV",+ON,DRGTYP,DRG,0)),(ADSTR,ADUNITS,SOLSTR)=""
.S @(DRGTYP_"STR")=$P(ND,U,2),ND=$G(^PS($S(DRGTYP="AD":52.6,1:52.7),+ND,0)),DDRG=$P(ND,U,2),DCST=$P(ND,U,7)
.I DRGTYP="AD" S Y=$P(ND,U,3) I Y S Y=$$CODES^PSIVUTL(Y,52.6,2) S ADUNITS=Y
.S ECUD=DFN_U_+ON_U_DDRG_U_PSIVNOW_U_PSIVC_U_ADSTR_U_ADUNITS_U_+SOLSTR_U_PROV_U_TYP_U_DCST
.S ECUD=ECUD_U_$P($G(^PS(55,DFN,"IV",+ON,"DSS")),"^")_U_START_U_IVROOM_U_DSDATE S ^TMP($J,DFN,ON,DDRG)=ECUD N PSII F PSII=1:1:PSIVNOL D ^ECXPIV1
Q1 L -^PS(50.8,PSIVSN) K PSIVD,PSIVTN,PSIVV,PSIVWD,PSIVLP Q
;
EN ;Compile IV stats hold file here.
I $D(PSIVSITE),$D(PSIVSN) K ZTSAVE S ZTDTH=$H,ZTDESC="COMPILE IV STATS (FROM MENU)",ZTRTN="EN^PSIVSTAT",ZTIO="" D ^%ZTLOAD W:$D(ZTSK) !,"Queued." G Q
;K ^TMP("PSIVNC",$J) S PSIVV=1,X="T-"_$S(+$G(^PS(59.7,1,31)):+^(31),1:100),%DT="" D ^%DT
;F X=0:0 S X=$O(^PS(50.8,X)) Q:'X F I=0:0 S I=$O(^PS(50.8,X,2,I)) Q:'I I I<Y K ^PS(50.8,X,2,I) S $P(^(0),U,4)=$P(^(0),U,4)-1
K ^TMP("PSIVNC",$J) F Q=0:0 S Q=$O(^PS(50.8,Q)) Q:'Q D
.S X="T-"_$S($P($G(^PS(59.5,Q,1)),U,19):$P(^(1),U,19),1:100) D ^%DT
.F I=0:0 S I=$O(^PS(50.8,Q,2,I)) Q:'I I I<Y K ^PS(50.8,Q,2,I) S $P(^(0),U,4)=$P(^(0),U,4)-1
;F PSIVS=0:0 S PSIVS=$O(^PS(50.8,PSIVS)) Q:'PSIVS L +^PS(50.8,PSIVS,0) D CNT L -^PS(50.8,PSIVS,0)
F PSIVS=0:0 S PSIVS=$O(^PS(50.8,PSIVS)) Q:'PSIVS D D CNT L -^PS(50.8,PSIVS,0)
.F L +^PS(50.8,PSIVS,0):1 Q:$T
Q K D,PSGDT,PSIVNOL,PSIVD,PSIVC,PSIVS,PSIVV,%DT,Z,ZTSK,DFN,PSIV,PNL,POP,LO,IV,PSIVDG,PSIVDRG D ENIVKV^PSGSETU Q
CNT F DFN=0:0 S DFN=$O(^PS(50.8,PSIVS,1,DFN)) Q:'DFN F TN=0:0 S TN=$O(^PS(50.8,PSIVS,1,DFN,1,TN)) Q:'TN D SET
S:$D(ZTQUEUED) ZTREQ="@" I $D(^TMP("PSIVNC",$J)) D MSG K TN,ZTIO,ZTRTN,X,Y Q
K ^PS(50.8,PSIVS,1),TN,ZTIO,ZTRTN,X,Y Q
SET S TN=^PS(50.8,PSIVS,1,DFN,1,TN,0),ON=$P(TN,U,2),PSIVC=$P(TN,U,3),PSIVNOL=$P(TN,U,5),W42=$P(TN,U,6),PSIVD=$P(TN,U,4)\1
F PSIVDG=52.6,52.7 F I=0:0 S I=$O(^PS(55,DFN,"IV",+ON,$S(PSIVDG=52.6:"AD",1:"SOL"),I)) Q:'I!($D(NON)) S PSIVDRG=+^(I,0) I $P(^PS(PSIVDG,PSIVDRG,0),U,7)="" S NON=1 D NOCOST
I $D(NON) K PSIVDG,PSIVDRG,NON Q
D ^PSIVST2 K ^PS(50.8,PSIVS,1,DFN,1,+TN) Q
NOCOST ;Send message if the drug is missing a unit cost.
;
S $P(^PS(50.8,PSIVS,1,DFN,1,+TN,0),U,7)=PSIVDG_";"_PSIVDRG,NUM=$S('$D(NUM):1,1:NUM+1),^TMP("PSIVNC",$J,NUM,0)=$P(^PS(PSIVDG,PSIVDRG,0),U)_" IN THE "_$S(PSIVDG=52.6:"ADDITIVES",1:"SOLUTIONS")_" FILE." Q
MSG S XMDUZ="IV PHARMACY PACKAGE",XMSUB="MISSING COST INFORMATION",XMTEXT="^TMP(""PSIVNC"",$J,"
F PSIVDUZ=0:0 S PSIVDUZ=$O(^XUSEC("PSJI MGR",PSIVDUZ)) Q:'PSIVDUZ S XMY(PSIVDUZ)=""
D ^XMD K ^TMP("PSIVNC",$J),XMY,XMDUZ,NUM,XMTEXT,PSIVDUZ,XMSUB
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVSTAT 4864 printed Oct 16, 2024@18:05:53 Page 2
PSIVSTAT ;BIR/PR-BUILD COST TRANS NODE, ENTER COMPILE ;6 Nov 98 / 4:45 PM
+1 ;;5.0;INPATIENT MEDICATIONS ;**3,18,84,81,104,111,130,199,345**;16 DEC 97;Build 1
+2 ;
+3 ; Reference to ^ECXPIV1 is supported by DBIA# 1882.
+4 ; Reference to ^PS(52.6 is supported by DBIA# 1231.
+5 ; Reference to ^PS(52.7 is supported by DBIA# 2173.
+6 ; Reference to ^PS(55 is supported by DBIA# 2191.
+7 ;
+8 ;Needs dfn,on,psivnol,psivc (optional:dis/ret/des).
+9 ;
+10 SET PSIVV=1
LOCK +^PS(50.8,PSIVSN):5000
+11 IF '$GET(PSIVC)
SET PSIVC=$SELECT(($GET(PSJRDC)="R"):2,($GET(PSJRDC)="D"):3,($GET(PSJRDC)]""):4,1:1)
+12 ;D NOW^%DTC S (Y,PSIVNOW)=% I '$D(^PS(50.8,PSIVSN,0)) L +^PS(50.8,0) S ^PS(50.8,PSIVSN,0)=PSIVSN,$P(^(0),U,3,4)=PSIVSN_U_($P(^PS(50.8,0),U,4)+1) L -^PS(50.8,0)
+13 DO NOW^%DTC
SET (Y,PSIVNOW)=%
IF '$DATA(^PS(50.8,PSIVSN,0))
Begin DoDot:1
+14 FOR
LOCK +^PS(50.8,0):1
if $TEST
QUIT
End DoDot:1
SET ^PS(50.8,PSIVSN,0)=PSIVSN
SET $PIECE(^(0),U,3,4)=PSIVSN_U_($PIECE(^PS(50.8,0),U,4)+1)
LOCK -^PS(50.8,0)
+15 SET $PIECE(^PS(50.8,PSIVSN,1,0),U,1,3)="^50.801P^"_DFN
if '$DATA(^(DFN,0))
SET ^(0)=DFN
SET $PIECE(^(0),U,3,4)=DFN_U_($PIECE(^PS(50.8,PSIVSN,1,0),U,4)+1)
+16 SET PSIVTN=1
IF $DATA(^PS(50.8,PSIVSN,1,DFN,1,0))
FOR PSIVTN=$PIECE(^(0),U,3)+1:1
if '$DATA(^PS(50.8,PSIVSN,1,DFN,1,PSIVTN,0))
QUIT
+17 ;
RETDET ;Get the ward that returns or destroyed need to be associated with.
+1 ;RDFLAG & RDWARD ARE set in routine PSIVRD.
+2 IF $DATA(RDFLAG)
SET PSIVWD=RDWARD
if '$DATA(^PS(55,DFN,"IV",+ON,9))
SET $PIECE(^(9),U,1,2)=""
SET $PIECE(^(9),U,3)=$PIECE(^(9),U,3)-PSIVNOL
GOTO SKIP
+3 ;
LBWD ;Get the ward we that we are printing labels on.
+1 SET PSIVWD=$PIECE(^PS(55,DFN,"IV",+ON,0),U,22)
if PSIVWD
GOTO SKIP
+2 SET PSIVWD=$SELECT($DATA(^DPT(DFN,.1)):$ORDER(^DIC(42,"B",^DPT(DFN,.1),0)),1:.5)
+3 ;
SKIP ;
+1 ;Set up the transaction node here.
+2 SET ^PS(50.8,PSIVSN,1,DFN,1,0)="^50.802^"_PSIVTN_U_PSIVTN
SET ^(PSIVTN,0)=PSIVTN_U_+ON_U_PSIVC_U_PSIVNOW_U_PSIVNOL_U_PSIVWD
+3 ;
DSS ; Update DSS for IV extract
+1 ;
+2 SET X="ECXPIV1"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT
+3 NEW ADSTR,ADUNITS,DCST,DDRG,DRG,PROV,SOLSTR,TYP,START,IVROOM,DSDATE,A,B
+4 KILL ^TMP($JOB)
+5 SET X=$GET(^PS(55,DFN,"IV",+ON,0))
SET PROV=$PIECE(X,U,6)
SET TYP=$PIECE(X,U,4)
SET START=$PIECE(X,U,2)
+6 SET A=$GET(^PS(55,DFN,"IV",+ON,2))
SET IVROOM=$PIECE(A,"^",2)
SET B=$GET(^PS(55,DFN,"IV",+ON,4))
SET DSDATE=$SELECT($PIECE(B,"^",2)]"":$PIECE(B,"^",2),1:$PIECE(A,"^"))
+7 FOR DRGTYP="AD","SOL"
FOR DRG=0:0
SET DRG=$ORDER(^PS(55,DFN,"IV",+ON,DRGTYP,DRG))
if 'DRG
QUIT
Begin DoDot:1
+8 SET ND=$GET(^PS(55,DFN,"IV",+ON,DRGTYP,DRG,0))
SET (ADSTR,ADUNITS,SOLSTR)=""
+9 SET @(DRGTYP_"STR")=$PIECE(ND,U,2)
SET ND=$GET(^PS($SELECT(DRGTYP="AD":52.6,1:52.7),+ND,0))
SET DDRG=$PIECE(ND,U,2)
SET DCST=$PIECE(ND,U,7)
+10 IF DRGTYP="AD"
SET Y=$PIECE(ND,U,3)
IF Y
SET Y=$$CODES^PSIVUTL(Y,52.6,2)
SET ADUNITS=Y
+11 SET ECUD=DFN_U_+ON_U_DDRG_U_PSIVNOW_U_PSIVC_U_ADSTR_U_ADUNITS_U_+SOLSTR_U_PROV_U_TYP_U_DCST
+12 SET ECUD=ECUD_U_$PIECE($GET(^PS(55,DFN,"IV",+ON,"DSS")),"^")_U_START_U_IVROOM_U_DSDATE
SET ^TMP($JOB,DFN,ON,DDRG)=ECUD
NEW PSII
FOR PSII=1:1:PSIVNOL
DO ^ECXPIV1
End DoDot:1
Q1 LOCK -^PS(50.8,PSIVSN)
KILL PSIVD,PSIVTN,PSIVV,PSIVWD,PSIVLP
QUIT
+1 ;
EN ;Compile IV stats hold file here.
+1 IF $DATA(PSIVSITE)
IF $DATA(PSIVSN)
KILL ZTSAVE
SET ZTDTH=$HOROLOG
SET ZTDESC="COMPILE IV STATS (FROM MENU)"
SET ZTRTN="EN^PSIVSTAT"
SET ZTIO=""
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Queued."
GOTO Q
+2 ;K ^TMP("PSIVNC",$J) S PSIVV=1,X="T-"_$S(+$G(^PS(59.7,1,31)):+^(31),1:100),%DT="" D ^%DT
+3 ;F X=0:0 S X=$O(^PS(50.8,X)) Q:'X F I=0:0 S I=$O(^PS(50.8,X,2,I)) Q:'I I I<Y K ^PS(50.8,X,2,I) S $P(^(0),U,4)=$P(^(0),U,4)-1
+4 KILL ^TMP("PSIVNC",$JOB)
FOR Q=0:0
SET Q=$ORDER(^PS(50.8,Q))
if 'Q
QUIT
Begin DoDot:1
+5 SET X="T-"_$SELECT($PIECE($GET(^PS(59.5,Q,1)),U,19):$PIECE(^(1),U,19),1:100)
DO ^%DT
+6 FOR I=0:0
SET I=$ORDER(^PS(50.8,Q,2,I))
if 'I
QUIT
IF I<Y
KILL ^PS(50.8,Q,2,I)
SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)-1
End DoDot:1
+7 ;F PSIVS=0:0 S PSIVS=$O(^PS(50.8,PSIVS)) Q:'PSIVS L +^PS(50.8,PSIVS,0) D CNT L -^PS(50.8,PSIVS,0)
+8 FOR PSIVS=0:0
SET PSIVS=$ORDER(^PS(50.8,PSIVS))
if 'PSIVS
QUIT
Begin DoDot:1
+9 FOR
LOCK +^PS(50.8,PSIVS,0):1
if $TEST
QUIT
End DoDot:1
DO CNT
LOCK -^PS(50.8,PSIVS,0)
Q KILL D,PSGDT,PSIVNOL,PSIVD,PSIVC,PSIVS,PSIVV,%DT,Z,ZTSK,DFN,PSIV,PNL,POP,LO,IV,PSIVDG,PSIVDRG
DO ENIVKV^PSGSETU
QUIT
CNT FOR DFN=0:0
SET DFN=$ORDER(^PS(50.8,PSIVS,1,DFN))
if 'DFN
QUIT
FOR TN=0:0
SET TN=$ORDER(^PS(50.8,PSIVS,1,DFN,1,TN))
if 'TN
QUIT
DO SET
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
IF $DATA(^TMP("PSIVNC",$JOB))
DO MSG
KILL TN,ZTIO,ZTRTN,X,Y
QUIT
+2 KILL ^PS(50.8,PSIVS,1),TN,ZTIO,ZTRTN,X,Y
QUIT
SET SET TN=^PS(50.8,PSIVS,1,DFN,1,TN,0)
SET ON=$PIECE(TN,U,2)
SET PSIVC=$PIECE(TN,U,3)
SET PSIVNOL=$PIECE(TN,U,5)
SET W42=$PIECE(TN,U,6)
SET PSIVD=$PIECE(TN,U,4)\1
+1 FOR PSIVDG=52.6,52.7
FOR I=0:0
SET I=$ORDER(^PS(55,DFN,"IV",+ON,$SELECT(PSIVDG=52.6:"AD",1:"SOL"),I))
if 'I!($DATA(NON))
QUIT
SET PSIVDRG=+^(I,0)
IF $PIECE(^PS(PSIVDG,PSIVDRG,0),U,7)=""
SET NON=1
DO NOCOST
+2 IF $DATA(NON)
KILL PSIVDG,PSIVDRG,NON
QUIT
+3 DO ^PSIVST2
KILL ^PS(50.8,PSIVS,1,DFN,1,+TN)
QUIT
NOCOST ;Send message if the drug is missing a unit cost.
+1 ;
+2 SET $PIECE(^PS(50.8,PSIVS,1,DFN,1,+TN,0),U,7)=PSIVDG_";"_PSIVDRG
SET NUM=$SELECT('$DATA(NUM):1,1:NUM+1)
SET ^TMP("PSIVNC",$JOB,NUM,0)=$PIECE(^PS(PSIVDG,PSIVDRG,0),U)_" IN THE "_$SELECT(PSIVDG=52.6:"ADDITIVES",1:"SOLUTIONS")_" FILE."
QUIT
MSG SET XMDUZ="IV PHARMACY PACKAGE"
SET XMSUB="MISSING COST INFORMATION"
SET XMTEXT="^TMP(""PSIVNC"",$J,"
+1 FOR PSIVDUZ=0:0
SET PSIVDUZ=$ORDER(^XUSEC("PSJI MGR",PSIVDUZ))
if 'PSIVDUZ
QUIT
SET XMY(PSIVDUZ)=""
+2 DO ^XMD
KILL ^TMP("PSIVNC",$JOB),XMY,XMDUZ,NUM,XMTEXT,PSIVDUZ,XMSUB
+3 QUIT
