- 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 Jan 18, 2025@03:06:21 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