Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSIVSTAT

PSIVSTAT.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Reference to ^ECXPIV1 is supported by DBIA# 1882.
  1. ; Reference to ^PS(52.6 is supported by DBIA# 1231.
  1. ; Reference to ^PS(52.7 is supported by DBIA# 2173.
  1. ; Reference to ^PS(55 is supported by DBIA# 2191.
  1. ;
  1. ;Needs dfn,on,psivnol,psivc (optional:dis/ret/des).
  1. ;
  1. S PSIVV=1 L +^PS(50.8,PSIVSN):5000
  1. I '$G(PSIVC) S PSIVC=$S(($G(PSJRDC)="R"):2,($G(PSJRDC)="D"):3,($G(PSJRDC)]""):4,1: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)
  1. 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)
  1. .F L +^PS(50.8,0):1 Q:$T
  1. 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)
  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))
  1. ;
  1. RETDET ;Get the ward that returns or destroyed need to be associated with.
  1. ;RDFLAG & RDWARD ARE set in routine PSIVRD.
  1. 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
  1. ;
  1. LBWD ;Get the ward we that we are printing labels on.
  1. S PSIVWD=$P(^PS(55,DFN,"IV",+ON,0),U,22) G:PSIVWD SKIP
  1. S PSIVWD=$S($D(^DPT(DFN,.1)):$O(^DIC(42,"B",^DPT(DFN,.1),0)),1:.5)
  1. ;
  1. SKIP ;
  1. ;Set up the transaction node here.
  1. 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
  1. ;
  1. DSS ; Update DSS for IV extract
  1. ;
  1. S X="ECXPIV1" X ^%ZOSF("TEST") Q:'$T
  1. N ADSTR,ADUNITS,DCST,DDRG,DRG,PROV,SOLSTR,TYP,START,IVROOM,DSDATE,A,B
  1. K ^TMP($J)
  1. S X=$G(^PS(55,DFN,"IV",+ON,0)),PROV=$P(X,U,6),TYP=$P(X,U,4),START=$P(X,U,2)
  1. 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,"^"))
  1. F DRGTYP="AD","SOL" F DRG=0:0 S DRG=$O(^PS(55,DFN,"IV",+ON,DRGTYP,DRG)) Q:'DRG D
  1. .S ND=$G(^PS(55,DFN,"IV",+ON,DRGTYP,DRG,0)),(ADSTR,ADUNITS,SOLSTR)=""
  1. .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)
  1. .I DRGTYP="AD" S Y=$P(ND,U,3) I Y S Y=$$CODES^PSIVUTL(Y,52.6,2) S ADUNITS=Y
  1. .S ECUD=DFN_U_+ON_U_DDRG_U_PSIVNOW_U_PSIVC_U_ADSTR_U_ADUNITS_U_+SOLSTR_U_PROV_U_TYP_U_DCST
  1. .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
  1. Q1 L -^PS(50.8,PSIVSN) K PSIVD,PSIVTN,PSIVV,PSIVWD,PSIVLP Q
  1. ;
  1. EN ;Compile IV stats hold file here.
  1. 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
  1. ;K ^TMP("PSIVNC",$J) S PSIVV=1,X="T-"_$S(+$G(^PS(59.7,1,31)):+^(31),1:100),%DT="" D ^%DT
  1. ;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
  1. K ^TMP("PSIVNC",$J) F Q=0:0 S Q=$O(^PS(50.8,Q)) Q:'Q D
  1. .S X="T-"_$S($P($G(^PS(59.5,Q,1)),U,19):$P(^(1),U,19),1:100) D ^%DT
  1. .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
  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)
  1. F PSIVS=0:0 S PSIVS=$O(^PS(50.8,PSIVS)) Q:'PSIVS D D CNT L -^PS(50.8,PSIVS,0)
  1. .F L +^PS(50.8,PSIVS,0):1 Q:$T
  1. Q K D,PSGDT,PSIVNOL,PSIVD,PSIVC,PSIVS,PSIVV,%DT,Z,ZTSK,DFN,PSIV,PNL,POP,LO,IV,PSIVDG,PSIVDRG D ENIVKV^PSGSETU Q
  1. 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
  1. S:$D(ZTQUEUED) ZTREQ="@" I $D(^TMP("PSIVNC",$J)) D MSG K TN,ZTIO,ZTRTN,X,Y Q
  1. K ^PS(50.8,PSIVS,1),TN,ZTIO,ZTRTN,X,Y Q
  1. 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
  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
  1. I $D(NON) K PSIVDG,PSIVDRG,NON Q
  1. D ^PSIVST2 K ^PS(50.8,PSIVS,1,DFN,1,+TN) Q
  1. NOCOST ;Send message if the drug is missing a unit cost.
  1. ;
  1. 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
  1. MSG S XMDUZ="IV PHARMACY PACKAGE",XMSUB="MISSING COST INFORMATION",XMTEXT="^TMP(""PSIVNC"",$J,"
  1. F PSIVDUZ=0:0 S PSIVDUZ=$O(^XUSEC("PSJI MGR",PSIVDUZ)) Q:'PSIVDUZ S XMY(PSIVDUZ)=""
  1. D ^XMD K ^TMP("PSIVNC",$J),XMY,XMDUZ,NUM,XMTEXT,PSIVDUZ,XMSUB
  1. Q