source: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSIVSTAT.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.6 KB
Line 
1PSIVSTAT ;BIR/PR-BUILD COST TRANS NODE, ENTER COMPILE ;6 Nov 98 / 4:45 PM
2 ;;5.0; INPATIENT MEDICATIONS ;**3,18,84,81,104,111,130**;16 DEC 97
3 ;
4 ; Reference to ^ECXPIV1 is supported by DBIA# 1882.
5 ; Reference to ^PS(52.6 is supported by DBIA# 1231.
6 ; Reference to ^PS(52.7 is supported by DBIA# 2173.
7 ; Reference to ^PS(55 is supported by DBIA# 2191.
8 ;
9 ;Needs dfn,on,psivnol,psivc (optional:dis/ret/des).
10 ;
11 S PSIVV=1 L +^PS(50.8,PSIVSN):5000
12 I '$G(PSIVC) S PSIVC=$S(($G(PSJRDC)="R"):2,($G(PSJRDC)="D"):3,($G(PSJRDC)]""):4,1:1)
13 ;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)
14 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)
15 .F L +^PS(50.8,0):1 Q:$T
16 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)
17 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))
18 ;
19RETDET ;Get the ward that returns or destroyed need to be associated with.
20 ;RDFLAG & RDWARD ARE set in routine PSIVRD.
21 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
22 ;
23LBWD ;Get the ward we that we are printing labels on.
24 S PSIVWD=$P(^PS(55,DFN,"IV",+ON,0),U,22) G:PSIVWD SKIP
25 S PSIVWD=$S($D(^DPT(DFN,.1)):$O(^DIC(42,"B",^DPT(DFN,.1),0)),1:.5)
26 ;
27SKIP ;
28 ;Set up the transaction node here.
29 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
30 ;
31DSS ; Update DSS for IV extract
32 ;
33 S X="ECXPIV1" X ^%ZOSF("TEST") Q:'$T
34 N ADSTR,ADUNITS,DCST,DDRG,DRG,PROV,SOLSTR,TYP,START,IVROOM,DSDATE,A,B
35 K ^TMP($J)
36 S X=$G(^PS(55,DFN,"IV",+ON,0)),PROV=$P(X,U,6),TYP=$P(X,U,4),START=$P(X,U,2)
37 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,"^"))
38 F DRGTYP="AD","SOL" F DRG=0:0 S DRG=$O(^PS(55,DFN,"IV",+ON,DRGTYP,DRG)) Q:'DRG D
39 .S ND=$G(^PS(55,DFN,"IV",+ON,DRGTYP,DRG,0)),(ADSTR,ADUNITS,SOLSTR)=""
40 .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)
41 .I DRGTYP="AD" S Y=$P(ND,U,3) I Y S Y=$$CODES^PSIVUTL(Y,52.6,2) S ADUNITS=Y
42 .S ECUD=DFN_U_+ON_U_DDRG_U_PSIVNOW_U_PSIVC_U_ADSTR_U_ADUNITS_U_+SOLSTR_U_PROV_U_TYP_U_DCST
43 .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 D ^ECXPIV1
44Q1 L -^PS(50.8,PSIVSN) K PSIVD,PSIVTN,PSIVV,PSIVWD,PSIVLP Q
45 ;
46EN ;Compile IV stats hold file here.
47 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
48 ;K ^TMP("PSIVNC",$J) S PSIVV=1,X="T-"_$S(+$G(^PS(59.7,1,31)):+^(31),1:100),%DT="" D ^%DT
49 ;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
50 K ^TMP("PSIVNC",$J) F Q=0:0 S Q=$O(^PS(50.8,Q)) Q:'Q D
51 .S X="T-"_$S($P($G(^PS(59.5,Q,1)),U,19):$P(^(1),U,19),1:100) D ^%DT
52 .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
53 ;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)
54 F PSIVS=0:0 S PSIVS=$O(^PS(50.8,PSIVS)) Q:'PSIVS D D CNT L -^PS(50.8,PSIVS,0)
55 .F L +^PS(50.8,PSIVS,0):1 Q:$T
56Q K D,PSGDT,PSIVNOL,PSIVD,PSIVC,PSIVS,PSIVV,%DT,Z,ZTSK,DFN,PSIV,PNL,POP,LO,IV,PSIVDG,PSIVDRG D ENIVKV^PSGSETU Q
57CNT 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
58 S:$D(ZTQUEUED) ZTREQ="@" I $D(^TMP("PSIVNC",$J)) D MSG K TN,ZTIO,ZTRTN,X,Y Q
59 K ^PS(50.8,PSIVS,1),TN,ZTIO,ZTRTN,X,Y Q
60SET 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
61 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
62 I $D(NON) K PSIVDG,PSIVDRG,NON Q
63 D ^PSIVST2 K ^PS(50.8,PSIVS,1,DFN,1,+TN) Q
64NOCOST ;Send message if the drug is missing a unit cost.
65 ;
66 S $P(^PS(50.8,PSIVS,1,DFN,1,+TN,0),U,7)=PSIVDG_";"_PSIVDRG,NUM=$S('$D(NUM):1,1:NUM+1),^TMP($J,"PSIVNC",NUM,0)=$P(^PS(PSIVDG,PSIVDRG,0),U)_" IN THE "_$S(PSIVDG=52.6:"ADDITIVES",1:"SOLUTIONS")_" FILE." Q
67MSG S XMDUZ="IV PHARMACY PACKAGE",XMSUB="MISSING COST INFORMATION",XMTEXT="^TMP(""PSIVNC"",$J,"
68 F PSIVDUZ=0:0 S PSIVDUZ=$O(^XUSEC("PSJI MGR",PSIVDUZ)) Q:'PSIVDUZ S XMY(PSIVDUZ)=""
69 D ^XMD K TMP("PSIVNC",$J),XMY,XMDUZ,NUM,XMTEXT,PSIVDUZ,XMSUB
70 Q
Note: See TracBrowser for help on using the repository browser.