PSUV1 ;BIR/CFL - Extract Data of PBM IV Module ; 6/10/15 3:28pm
;;4.0;PHARMACY BENEFITS MANAGEMENT;**1**;MARCH, 2005;Build 5
;DBIAs
; Reference to file #55 supported by DBIA 2497
; Reference to file #59.5 supported by DBIA 2499
; Reference to file #40.8 supported by DBIA 2438
; Reference to file #7 supported by DBIA 2495
; Reference to file #49 supported by DBIA 10093
; Reference to file #52.6 supported by DBIA 436
; Reference to file #50 supported by DBIA 221
; Reference to file #52.7 supported by DBIA 437
; Reference to file #2 supported by DBIA 10035 and 2701
; Reference to file #200 supported by DBIA 10060
;
IVDATA ;Loop through IV data
N PSUDOC1
K PSUSSNA,PSUORDA
; *34 |==>
S PSUIVDT=PSUSDT\1-.0001 ;use 1st day of extract for 'stop date' scan
S PSUTEDT=PSUEDT\1+.2359
F S PSUIVDT=$O(^PS(55,"AIV",PSUIVDT)) Q:'PSUIVDT D
.S PSUPDA=""
.F S PSUPDA=$O(^PS(55,"AIV",PSUIVDT,PSUPDA)) Q:'PSUPDA D
..S PSUODA=""
..F S PSUODA=$O(^PS(55,"AIV",PSUIVDT,PSUPDA,PSUODA)) Q:'PSUODA D
...S ^XTMP("PSU_"_PSUJOB,"PSUHLD",PSUODA)="" ;should be the D0's for file 55.01 ; <==| *34
...S COUNT=0
...S PSUDIV=""
...K PSUIV
...; screen test patients
...Q:$$TESTPAT^PSUTL1(PSUPDA)
...S XX=$$VALI^PSUTL(55.01,"PSUPDA,PSUODA",.02) Q:XX>PSUTEDT ;*34
...K PSUIV ;*34
...D GETS^PSUTL(55.01,"PSUPDA,PSUODA",".01;.02;.03;.04;.06;.08;.09;.22;104;106;108","PSUIV","I")
...;.01-Order num;.02-Start Dt;.03-Stop Dt;.04-Type;.06-Provider
...;104-Ward;106-Chemotherapy Type;108-Intermittent Syringe
...Q:'$D(PSUIV)
...;VMP OIFO BAY PINES;ELR;PSU*3*35 ADDED NEXT LINE
...Q:$G(PSUIV(.06,"I"))'>0
...S ^XTMP("PSU_"_PSUJOB,"PSUPIEN",PSUPDA)="" ;Patient IEN's ;*34
...D MOVEI^PSUTL("PSUIV")
...S PSUIV(.02)=PSUIV(.02)\1
...S PSUIV(.03)=PSUIV(.03)\1
...I PSUIV(.22)'="" S PSUDIV=$$VALI^PSUTL(59.5,PSUIV(.22),.02)
...S PSUFAC=$$VALI^PSUTL(40.8,PSUDIV,1) S:PSUFAC="" PSUFAC=PSUSNDR
...S PSUFAC(PSUFAC)=""
...S PSUOUTP=$S(PSUIV(104)=.5:"Y",1:"N")
...S DFN=PSUPDA D PID^VADPT
...S PSUSSN=$TR(VA("PID"),"^-","")
...D ICN
...K PSUDOC
...D GETS^PSUTL(200,"PSUIV(.06)","9;29;53.5","PSUDOC","I")
...D MOVEI^PSUTL("PSUDOC")
...I $G(PSUDOC(9))="" S PSUVSSN1=999999999
...I $G(PSUDOC(9))'="" S PSUVSSN1=PSUDOC(9)
...S ^XTMP("PSU_"_PSUJOB,"PSUPDR",PSUVSSN1,PSUIV(.06))=""
...S (PSUPCLS,PSUSP1,PSUSP2)=""
...I $D(PSUDOC(53.5)),PSUDOC(53.5)'="" D
....S PSUPCLS=$$VALI^PSUTL(7,PSUDOC(53.5),1)
....I PSUPCLS="" S PSUPCLS=$$VALI^PSUTL(7,PSUDOC(53.5),.01)
...S PSUPSV=$S($L($G(PSUDOC(29))):$$VAL^PSUTL(49,PSUDOC(29),.01),1:"")
...S PSUPSV=$$UPPER^PSUTL(PSUPSV),PSUSERV=""
...I $L(PSUPSV),$D(PSECT(PSUPSV)) S PSUSERV=PSECT(PSUPSV)
...S SPECPTR=$$GET^XUA4A72(PSUIV(.06),PSUIVDT)
...S PSUSP1=$P($G(SPECPTR),U,3),PSUSP2=$P($G(SPECPTR),U,4)
...D OCCAMT
...I PSUFND D
....D GETRATE^PSUV2(PSUIV(.04))
....D SETTOT
....S RECTYP=""
....D ADDTIV
....D SOLUTN
I $D(^XTMP(PSUIVSUB,"RECORDS")) D SETSUM^PSUV2
Q
;
ICN ;Find patient ICN
;
N PSUPICN,PSUPICN1,PSUICN
S PSUPTN=0
I $G(PSUSSN),PSUSSN'="" D
.F S PSUPTN=$O(^DPT("SSN",PSUSSN,PSUPTN)) Q:PSUPTN="" D
..S PSUPICN1=$$GETICN^MPIF001(PSUPTN) D
...I PSUPICN1'[-1 D
....S ^XTMP("PSU_"_PSUJOB,"PSUPICN")=PSUPICN1
...I PSUPICN1[-1 S ^XTMP("PSU_"_PSUJOB,"PSUPICN")=""
Q
;
;
OCCAMT ;Calculate the number of dispensing occurrences
S (PSUFND,PSUDISP,PSUPULL,OCC,PSUDISPT,PSURECT,PSUDEST,PSUCAN)=0
F S OCC=$O(^PS(55,PSUPDA,"IV",PSUODA,"LAB",OCC)) Q:'OCC D
.K PSUOCC
.D GETS^PSUTL(55.1111,"PSUPDA,PSUODA,OCC","1;2;4;6","PSUOCC","I")
.D MOVEI^PSUTL("PSUOCC")
.S PSUOCC(1)=PSUOCC(1)\1
.I PSUOCC(1)<PSUSDT!(PSUOCC(1)>PSUTEDT) Q ;*34
.S PSUFND=1
.I $G(PSUOCC(6))=1,$G(PSUOCC(2))=1 D
..S PSUDISP=PSUDISP+$G(PSUOCC(4))
..S PSUDISPT=PSUDISP ;Total IV dispensed
..S PSUPULL=PSUPULL+$G(PSUOCC(4))
..S ^XTMP(PSUIVSUB,"TYPE_"_PSUIV(.04),PSUFAC)=PSUOCC(4)+$G(^XTMP(PSUIVSUB,"TYPE_"_PSUIV(.04),PSUFAC))
..I PSUOUTP="Y" D ; Total outpatient IV's dispensed
...S ^XTMP(PSUIVSUB,"ODISP",PSUFAC)=$G(^XTMP(PSUIVSUB,"ODISP",PSUFAC))+PSUOCC(4)
.;I PSUOCC(2)=2!(PSUOCC(2)=4) S PSUDISP=PSUDISP-PSUOCC(4)
.I PSUOCC(2)=2 D
..S PSURECT=$G(PSURECT)+PSUOCC(4),PSUDISP=PSUDISP-PSUOCC(4) ;Total IV Recycled
.I PSUOCC(2)=3 D
..S PSUDEST=$G(PSUDEST)+PSUOCC(4),PSUDISP=PSUDISP-PSUOCC(4) ;Total IV Destroyed
.I PSUOCC(2)=4 D
..S PSUCAN=$G(PSUCAN)+PSUOCC(4),PSUDISP=PSUDISP-PSUOCC(4) ;Total IV Cancelled
Q
SETTOT ;Set totals
; Total number of IV's ordered
S ^XTMP(PSUIVSUB,"ORD",PSUFAC)=$G(^XTMP(PSUIVSUB,"ORD",PSUFAC))+1
; Total number of IV patients
I '$D(^XTMP(PSUIVSUB,"PAT",PSUSSN,PSUFAC)) D
.S ^XTMP(PSUIVSUB,"SSN",PSUFAC)=$G(^XTMP(PSUIVSUB,"SSN",PSUFAC))+1
.S ^XTMP(PSUIVSUB,"PAT",PSUSSN,PSUFAC)=""
.S PSUDIV=PSUFAC D GETDIV^PSUV3 I PSUDIVNM'="" D
..S ^XTMP("PSU_"_PSUJOB,"PSUDIV",PSUDIVNM,PSUSSN)="" ;Pt demo summary
.I PSUDIVNM="" S ^XTMP("PSU_"_PSUJOB,"PSUDIV",PSUDIV,PSUSSN)=""
I PSUOUTP="Y" D
.; Total outpatient IV's ordered
.S ^XTMP(PSUIVSUB,"OORD",PSUFAC)=$G(^XTMP(PSUIVSUB,"OORD",PSUFAC))+1
Q
ADDTIV ;Loop through each additive
S (PSUNITS,ADTIV)=0
F S ADTIV=$O(^PS(55,PSUPDA,"IV",PSUODA,"AD",ADTIV)) Q:'ADTIV D
.K PSUADDTV,PSUGNRIC,PSUADD
.D GETS^PSUTL(55.02,"PSUPDA,PSUODA,ADTIV",".01;.02","PSUADDTV","I")
.D MOVEI^PSUTL("PSUADDTV")
.D GETS^PSUTL(52.6,"PSUADDTV(.01)",".01;1;7","PSUGNRIC","I")
.D MOVEI^PSUTL("PSUGNRIC")
.S PSUPNAM=PSUGNRIC(.01)
.S PSUDGU=$$VAL^PSUTL(52.6,PSUADDTV(.01),2)
.S PSUDGDA=PSUGNRIC(1)
.D GETS^PSUTL(50,"PSUDGDA",".01;2;20;21;22;25;31;51;52;3","PSUADD","I")
.D MOVEI^PSUTL("PSUADD")
.S PSUGNM=PSUADD(.01)
.S PSUDCLS=PSUADD(2)
.S PSUPRNM=PSUADD(21)
.S PSUNDC=PSUADD(31)
.S PSUNFI=PSUADD(51)
.S PSUNADR=PSUADD(20)
.S PSUNDCL=PSUADD(22)
.S PSUDEA=PSUADD(3)
.S PSUNAF=$S(PSUADD(52):"N/F",1:"")
.D SETVAR
.S PSUSTRN=+PSUADDTV(.02)
.;
.;DAM Add AMIS Additive data
.N PSUTDSP1
.S PSUTDSP1=$G(PSUDISPT)*PSUSTRN ;Total Additive units dispens
.;
.N PSURCY1
.S PSURCY1=$G(PSURECT)*PSUSTRN ;Total Additive units recycled
.;
.N PSUDES1
.S PSUDES1=$G(PSUDEST)*PSUSTRN ;Total Additive units destroyed
.;
.N PSUCAN1
.S PSUCAN1=$G(PSUCAN)*PSUSTRN ;Total Additive units cancelled
.;END DAM
.S PSUNITS=PSUDISP*PSUSTRN
.S PSUBAGS=PSUPULL*PSUSTRN
.S PSUDCST=PSUGNRIC(7)
.S RECIND="A"
.D CALC
.D SETREC^PSUV2
.D SETDRUG^PSUV2
Q
SOLUTN ;Loop through each solution
S (PSUNITS,SOLDA)=0 F S SOLDA=$O(^PS(55,PSUPDA,"IV",PSUODA,"SOL",SOLDA)) Q:'SOLDA D
.K PSUSOL,GENRIC,SOLDRUG
.D GETS^PSUTL(55.11,"PSUPDA,PSUODA,SOLDA",".01;1","PSUSOL","I")
.D MOVEI^PSUTL("PSUSOL")
.D GETS^PSUTL(52.7,"PSUSOL(.01)",".01;1;7","GENRIC","I")
.D MOVEI^PSUTL("GENRIC")
.S PSUPNAM=GENRIC(.01)
.S PSUDGU="ML"
.S PSUDGDA=GENRIC(1)
.D GETS^PSUTL(50,"PSUDGDA",".01;2;20;21;22;25;31;51;52;3","SOLDRUG","I")
.D MOVEI^PSUTL("SOLDRUG")
.S PSUGNM=SOLDRUG(.01)
.S PSUDCLS=SOLDRUG(2)
.S PSUPRNM=SOLDRUG(21)
.S PSUNDC=SOLDRUG(31)
.S PSUNFI=SOLDRUG(51)
.S PSUNADR=SOLDRUG(20)
.S PSUNDCL=SOLDRUG(22)
.S PSUDEA=SOLDRUG(3)
.S PSUNAF=$S(SOLDRUG(52):"N/F",1:"")
.D SETVAR
.S VOLUME=+PSUSOL(1)
.;
.;DAM ADD AMIS SOLUTION DATA
.N PSUTSOL1
.S PSUTSOL1=$G(PSUDISPT)*VOLUME ;Total Solution units dispense
.;
.N PSUTRS1
.S PSUTRS1=$G(PSURECT)*VOLUME ;Total Solution units recycl
.;
.N PSUTDS1
.S PSUTDS1=$G(PSUDEST)*VOLUME ;Total Solution units destroyed
.;
.N PSUTCS1
.S PSUTCS1=$G(PSUCAN)*VOLUME ;Total Solution units cancelled
.;END DAM
.S PSUNITS=PSUDISP*VOLUME
.S PSUBAGS=PSUPULL*VOLUME
.S PSUDCST=GENRIC(7)
.S RECIND="S"
.D CALC
.D SETREC^PSUV2
.D SETDRUG^PSUV2
Q
SETVAR ;Setup common variables for IV Additives and Solutions
I PSUGNM="" S PSUGNM="UNKNOWN GENERIC NAME"
I PSUPRNM="" S PSUPRNM="UNKNOWN VA PRODUCT NAME"
I PSUNDC="" S PSUNDC="No NDC"
I PSUNFI=1 S PSUNFI="N/F"
S (PSIVNFI,PSIVNFR)=""
I $$VERSION^XPDUTL("PSN")'<4 D
.S PSIVNFI=$$FORMI^PSNAPIS(PSUNADR,PSUNDCL)
.S PSIVNFR=$$FORMR^PSNAPIS(PSUNADR,PSUNDCL)>0
Q
CALC ;Do calculations for additives and solutions
S ^XTMP(PSUIVSUB,"CST",PSUFAC)=(PSUNITS*PSUDCST)+$G(^XTMP(PSUIVSUB,"CST",PSUFAC))
S RECTYP=""
S COUNT=COUNT+1
S:COUNT=1 RECTYP="P"
I PSUOUTP="Y" D
.S ^XTMP(PSUIVSUB,"OCST",PSUFAC)=(PSUDCST*PSUBAGS)+$G(^XTMP(PSUIVSUB,"OCST",PSUFAC))
I PSUIV(.04)="P" D
.S ^XTMP(PSUIVSUB,"SPIG",PSUFAC)=(PSUDCST*PSUBAGS)+$G(^XTMP(PSUIVSUB,"SPIG",PSUFAC))
I PSUIV(.04)="A" D
.S ^XTMP(PSUIVSUB,"SADM",PSUFAC)=(PSUDCST*PSUBAGS)+$G(^XTMP(PSUIVSUB,"SADM",PSUFAC))
I PSUIV(.04)="H" D
.S ^XTMP(PSUIVSUB,"SHYP",PSUFAC)=(PSUDCST*PSUBAGS)+$G(^XTMP(PSUIVSUB,"SHYP",PSUFAC))
I PSUIV(.04)="S" D
.S ^XTMP(PSUIVSUB,"SSYR",PSUFAC)=(PSUDCST*PSUBAGS)+$G(^XTMP(PSUIVSUB,"SSYR",PSUFAC))
I PSUIV(.04)="C" D
.S ^XTMP(PSUIVSUB,"SCHEM",PSUFAC)=(PSUDCST*PSUBAGS)+$G(^XTMP(PSUIVSUB,"SCHEM",PSUFAC))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUV1 9081 printed Sep 23, 2025@20:04:24 Page 2
PSUV1 ;BIR/CFL - Extract Data of PBM IV Module ; 6/10/15 3:28pm
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**1**;MARCH, 2005;Build 5
+2 ;DBIAs
+3 ; Reference to file #55 supported by DBIA 2497
+4 ; Reference to file #59.5 supported by DBIA 2499
+5 ; Reference to file #40.8 supported by DBIA 2438
+6 ; Reference to file #7 supported by DBIA 2495
+7 ; Reference to file #49 supported by DBIA 10093
+8 ; Reference to file #52.6 supported by DBIA 436
+9 ; Reference to file #50 supported by DBIA 221
+10 ; Reference to file #52.7 supported by DBIA 437
+11 ; Reference to file #2 supported by DBIA 10035 and 2701
+12 ; Reference to file #200 supported by DBIA 10060
+13 ;
IVDATA ;Loop through IV data
+1 NEW PSUDOC1
+2 KILL PSUSSNA,PSUORDA
+3 ; *34 |==>
+4 ;use 1st day of extract for 'stop date' scan
SET PSUIVDT=PSUSDT\1-.0001
+5 SET PSUTEDT=PSUEDT\1+.2359
+6 FOR
SET PSUIVDT=$ORDER(^PS(55,"AIV",PSUIVDT))
if 'PSUIVDT
QUIT
Begin DoDot:1
+7 SET PSUPDA=""
+8 FOR
SET PSUPDA=$ORDER(^PS(55,"AIV",PSUIVDT,PSUPDA))
if 'PSUPDA
QUIT
Begin DoDot:2
+9 SET PSUODA=""
+10 FOR
SET PSUODA=$ORDER(^PS(55,"AIV",PSUIVDT,PSUPDA,PSUODA))
if 'PSUODA
QUIT
Begin DoDot:3
+11 ;should be the D0's for file 55.01 ; <==| *34
SET ^XTMP("PSU_"_PSUJOB,"PSUHLD",PSUODA)=""
+12 SET COUNT=0
+13 SET PSUDIV=""
+14 KILL PSUIV
+15 ; screen test patients
+16 if $$TESTPAT^PSUTL1(PSUPDA)
QUIT
+17 ;*34
SET XX=$$VALI^PSUTL(55.01,"PSUPDA,PSUODA",.02)
if XX>PSUTEDT
QUIT
+18 ;*34
KILL PSUIV
+19 DO GETS^PSUTL(55.01,"PSUPDA,PSUODA",".01;.02;.03;.04;.06;.08;.09;.22;104;106;108","PSUIV","I")
+20 ;.01-Order num;.02-Start Dt;.03-Stop Dt;.04-Type;.06-Provider
+21 ;104-Ward;106-Chemotherapy Type;108-Intermittent Syringe
+22 if '$DATA(PSUIV)
QUIT
+23 ;VMP OIFO BAY PINES;ELR;PSU*3*35 ADDED NEXT LINE
+24 if $GET(PSUIV(.06,"I"))'>0
QUIT
+25 ;Patient IEN's ;*34
SET ^XTMP("PSU_"_PSUJOB,"PSUPIEN",PSUPDA)=""
+26 DO MOVEI^PSUTL("PSUIV")
+27 SET PSUIV(.02)=PSUIV(.02)\1
+28 SET PSUIV(.03)=PSUIV(.03)\1
+29 IF PSUIV(.22)'=""
SET PSUDIV=$$VALI^PSUTL(59.5,PSUIV(.22),.02)
+30 SET PSUFAC=$$VALI^PSUTL(40.8,PSUDIV,1)
if PSUFAC=""
SET PSUFAC=PSUSNDR
+31 SET PSUFAC(PSUFAC)=""
+32 SET PSUOUTP=$SELECT(PSUIV(104)=.5:"Y",1:"N")
+33 SET DFN=PSUPDA
DO PID^VADPT
+34 SET PSUSSN=$TRANSLATE(VA("PID"),"^-","")
+35 DO ICN
+36 KILL PSUDOC
+37 DO GETS^PSUTL(200,"PSUIV(.06)","9;29;53.5","PSUDOC","I")
+38 DO MOVEI^PSUTL("PSUDOC")
+39 IF $GET(PSUDOC(9))=""
SET PSUVSSN1=999999999
+40 IF $GET(PSUDOC(9))'=""
SET PSUVSSN1=PSUDOC(9)
+41 SET ^XTMP("PSU_"_PSUJOB,"PSUPDR",PSUVSSN1,PSUIV(.06))=""
+42 SET (PSUPCLS,PSUSP1,PSUSP2)=""
+43 IF $DATA(PSUDOC(53.5))
IF PSUDOC(53.5)'=""
Begin DoDot:4
+44 SET PSUPCLS=$$VALI^PSUTL(7,PSUDOC(53.5),1)
+45 IF PSUPCLS=""
SET PSUPCLS=$$VALI^PSUTL(7,PSUDOC(53.5),.01)
End DoDot:4
+46 SET PSUPSV=$SELECT($LENGTH($GET(PSUDOC(29))):$$VAL^PSUTL(49,PSUDOC(29),.01),1:"")
+47 SET PSUPSV=$$UPPER^PSUTL(PSUPSV)
SET PSUSERV=""
+48 IF $LENGTH(PSUPSV)
IF $DATA(PSECT(PSUPSV))
SET PSUSERV=PSECT(PSUPSV)
+49 SET SPECPTR=$$GET^XUA4A72(PSUIV(.06),PSUIVDT)
+50 SET PSUSP1=$PIECE($GET(SPECPTR),U,3)
SET PSUSP2=$PIECE($GET(SPECPTR),U,4)
+51 DO OCCAMT
+52 IF PSUFND
Begin DoDot:4
+53 DO GETRATE^PSUV2(PSUIV(.04))
+54 DO SETTOT
+55 SET RECTYP=""
+56 DO ADDTIV
+57 DO SOLUTN
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+58 IF $DATA(^XTMP(PSUIVSUB,"RECORDS"))
DO SETSUM^PSUV2
+59 QUIT
+60 ;
ICN ;Find patient ICN
+1 ;
+2 NEW PSUPICN,PSUPICN1,PSUICN
+3 SET PSUPTN=0
+4 IF $GET(PSUSSN)
IF PSUSSN'=""
Begin DoDot:1
+5 FOR
SET PSUPTN=$ORDER(^DPT("SSN",PSUSSN,PSUPTN))
if PSUPTN=""
QUIT
Begin DoDot:2
+6 SET PSUPICN1=$$GETICN^MPIF001(PSUPTN)
Begin DoDot:3
+7 IF PSUPICN1'[-1
Begin DoDot:4
+8 SET ^XTMP("PSU_"_PSUJOB,"PSUPICN")=PSUPICN1
End DoDot:4
+9 IF PSUPICN1[-1
SET ^XTMP("PSU_"_PSUJOB,"PSUPICN")=""
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
+12 ;
OCCAMT ;Calculate the number of dispensing occurrences
+1 SET (PSUFND,PSUDISP,PSUPULL,OCC,PSUDISPT,PSURECT,PSUDEST,PSUCAN)=0
+2 FOR
SET OCC=$ORDER(^PS(55,PSUPDA,"IV",PSUODA,"LAB",OCC))
if 'OCC
QUIT
Begin DoDot:1
+3 KILL PSUOCC
+4 DO GETS^PSUTL(55.1111,"PSUPDA,PSUODA,OCC","1;2;4;6","PSUOCC","I")
+5 DO MOVEI^PSUTL("PSUOCC")
+6 SET PSUOCC(1)=PSUOCC(1)\1
+7 ;*34
IF PSUOCC(1)<PSUSDT!(PSUOCC(1)>PSUTEDT)
QUIT
+8 SET PSUFND=1
+9 IF $GET(PSUOCC(6))=1
IF $GET(PSUOCC(2))=1
Begin DoDot:2
+10 SET PSUDISP=PSUDISP+$GET(PSUOCC(4))
+11 ;Total IV dispensed
SET PSUDISPT=PSUDISP
+12 SET PSUPULL=PSUPULL+$GET(PSUOCC(4))
+13 SET ^XTMP(PSUIVSUB,"TYPE_"_PSUIV(.04),PSUFAC)=PSUOCC(4)+$GET(^XTMP(PSUIVSUB,"TYPE_"_PSUIV(.04),PSUFAC))
+14 ; Total outpatient IV's dispensed
IF PSUOUTP="Y"
Begin DoDot:3
+15 SET ^XTMP(PSUIVSUB,"ODISP",PSUFAC)=$GET(^XTMP(PSUIVSUB,"ODISP",PSUFAC))+PSUOCC(4)
End DoDot:3
End DoDot:2
+16 ;I PSUOCC(2)=2!(PSUOCC(2)=4) S PSUDISP=PSUDISP-PSUOCC(4)
+17 IF PSUOCC(2)=2
Begin DoDot:2
+18 ;Total IV Recycled
SET PSURECT=$GET(PSURECT)+PSUOCC(4)
SET PSUDISP=PSUDISP-PSUOCC(4)
End DoDot:2
+19 IF PSUOCC(2)=3
Begin DoDot:2
+20 ;Total IV Destroyed
SET PSUDEST=$GET(PSUDEST)+PSUOCC(4)
SET PSUDISP=PSUDISP-PSUOCC(4)
End DoDot:2
+21 IF PSUOCC(2)=4
Begin DoDot:2
+22 ;Total IV Cancelled
SET PSUCAN=$GET(PSUCAN)+PSUOCC(4)
SET PSUDISP=PSUDISP-PSUOCC(4)
End DoDot:2
End DoDot:1
+23 QUIT
SETTOT ;Set totals
+1 ; Total number of IV's ordered
+2 SET ^XTMP(PSUIVSUB,"ORD",PSUFAC)=$GET(^XTMP(PSUIVSUB,"ORD",PSUFAC))+1
+3 ; Total number of IV patients
+4 IF '$DATA(^XTMP(PSUIVSUB,"PAT",PSUSSN,PSUFAC))
Begin DoDot:1
+5 SET ^XTMP(PSUIVSUB,"SSN",PSUFAC)=$GET(^XTMP(PSUIVSUB,"SSN",PSUFAC))+1
+6 SET ^XTMP(PSUIVSUB,"PAT",PSUSSN,PSUFAC)=""
+7 SET PSUDIV=PSUFAC
DO GETDIV^PSUV3
IF PSUDIVNM'=""
Begin DoDot:2
+8 ;Pt demo summary
SET ^XTMP("PSU_"_PSUJOB,"PSUDIV",PSUDIVNM,PSUSSN)=""
End DoDot:2
+9 IF PSUDIVNM=""
SET ^XTMP("PSU_"_PSUJOB,"PSUDIV",PSUDIV,PSUSSN)=""
End DoDot:1
+10 IF PSUOUTP="Y"
Begin DoDot:1
+11 ; Total outpatient IV's ordered
+12 SET ^XTMP(PSUIVSUB,"OORD",PSUFAC)=$GET(^XTMP(PSUIVSUB,"OORD",PSUFAC))+1
End DoDot:1
+13 QUIT
ADDTIV ;Loop through each additive
+1 SET (PSUNITS,ADTIV)=0
+2 FOR
SET ADTIV=$ORDER(^PS(55,PSUPDA,"IV",PSUODA,"AD",ADTIV))
if 'ADTIV
QUIT
Begin DoDot:1
+3 KILL PSUADDTV,PSUGNRIC,PSUADD
+4 DO GETS^PSUTL(55.02,"PSUPDA,PSUODA,ADTIV",".01;.02","PSUADDTV","I")
+5 DO MOVEI^PSUTL("PSUADDTV")
+6 DO GETS^PSUTL(52.6,"PSUADDTV(.01)",".01;1;7","PSUGNRIC","I")
+7 DO MOVEI^PSUTL("PSUGNRIC")
+8 SET PSUPNAM=PSUGNRIC(.01)
+9 SET PSUDGU=$$VAL^PSUTL(52.6,PSUADDTV(.01),2)
+10 SET PSUDGDA=PSUGNRIC(1)
+11 DO GETS^PSUTL(50,"PSUDGDA",".01;2;20;21;22;25;31;51;52;3","PSUADD","I")
+12 DO MOVEI^PSUTL("PSUADD")
+13 SET PSUGNM=PSUADD(.01)
+14 SET PSUDCLS=PSUADD(2)
+15 SET PSUPRNM=PSUADD(21)
+16 SET PSUNDC=PSUADD(31)
+17 SET PSUNFI=PSUADD(51)
+18 SET PSUNADR=PSUADD(20)
+19 SET PSUNDCL=PSUADD(22)
+20 SET PSUDEA=PSUADD(3)
+21 SET PSUNAF=$SELECT(PSUADD(52):"N/F",1:"")
+22 DO SETVAR
+23 SET PSUSTRN=+PSUADDTV(.02)
+24 ;
+25 ;DAM Add AMIS Additive data
+26 NEW PSUTDSP1
+27 ;Total Additive units dispens
SET PSUTDSP1=$GET(PSUDISPT)*PSUSTRN
+28 ;
+29 NEW PSURCY1
+30 ;Total Additive units recycled
SET PSURCY1=$GET(PSURECT)*PSUSTRN
+31 ;
+32 NEW PSUDES1
+33 ;Total Additive units destroyed
SET PSUDES1=$GET(PSUDEST)*PSUSTRN
+34 ;
+35 NEW PSUCAN1
+36 ;Total Additive units cancelled
SET PSUCAN1=$GET(PSUCAN)*PSUSTRN
+37 ;END DAM
+38 SET PSUNITS=PSUDISP*PSUSTRN
+39 SET PSUBAGS=PSUPULL*PSUSTRN
+40 SET PSUDCST=PSUGNRIC(7)
+41 SET RECIND="A"
+42 DO CALC
+43 DO SETREC^PSUV2
+44 DO SETDRUG^PSUV2
End DoDot:1
+45 QUIT
SOLUTN ;Loop through each solution
+1 SET (PSUNITS,SOLDA)=0
FOR
SET SOLDA=$ORDER(^PS(55,PSUPDA,"IV",PSUODA,"SOL",SOLDA))
if 'SOLDA
QUIT
Begin DoDot:1
+2 KILL PSUSOL,GENRIC,SOLDRUG
+3 DO GETS^PSUTL(55.11,"PSUPDA,PSUODA,SOLDA",".01;1","PSUSOL","I")
+4 DO MOVEI^PSUTL("PSUSOL")
+5 DO GETS^PSUTL(52.7,"PSUSOL(.01)",".01;1;7","GENRIC","I")
+6 DO MOVEI^PSUTL("GENRIC")
+7 SET PSUPNAM=GENRIC(.01)
+8 SET PSUDGU="ML"
+9 SET PSUDGDA=GENRIC(1)
+10 DO GETS^PSUTL(50,"PSUDGDA",".01;2;20;21;22;25;31;51;52;3","SOLDRUG","I")
+11 DO MOVEI^PSUTL("SOLDRUG")
+12 SET PSUGNM=SOLDRUG(.01)
+13 SET PSUDCLS=SOLDRUG(2)
+14 SET PSUPRNM=SOLDRUG(21)
+15 SET PSUNDC=SOLDRUG(31)
+16 SET PSUNFI=SOLDRUG(51)
+17 SET PSUNADR=SOLDRUG(20)
+18 SET PSUNDCL=SOLDRUG(22)
+19 SET PSUDEA=SOLDRUG(3)
+20 SET PSUNAF=$SELECT(SOLDRUG(52):"N/F",1:"")
+21 DO SETVAR
+22 SET VOLUME=+PSUSOL(1)
+23 ;
+24 ;DAM ADD AMIS SOLUTION DATA
+25 NEW PSUTSOL1
+26 ;Total Solution units dispense
SET PSUTSOL1=$GET(PSUDISPT)*VOLUME
+27 ;
+28 NEW PSUTRS1
+29 ;Total Solution units recycl
SET PSUTRS1=$GET(PSURECT)*VOLUME
+30 ;
+31 NEW PSUTDS1
+32 ;Total Solution units destroyed
SET PSUTDS1=$GET(PSUDEST)*VOLUME
+33 ;
+34 NEW PSUTCS1
+35 ;Total Solution units cancelled
SET PSUTCS1=$GET(PSUCAN)*VOLUME
+36 ;END DAM
+37 SET PSUNITS=PSUDISP*VOLUME
+38 SET PSUBAGS=PSUPULL*VOLUME
+39 SET PSUDCST=GENRIC(7)
+40 SET RECIND="S"
+41 DO CALC
+42 DO SETREC^PSUV2
+43 DO SETDRUG^PSUV2
End DoDot:1
+44 QUIT
SETVAR ;Setup common variables for IV Additives and Solutions
+1 IF PSUGNM=""
SET PSUGNM="UNKNOWN GENERIC NAME"
+2 IF PSUPRNM=""
SET PSUPRNM="UNKNOWN VA PRODUCT NAME"
+3 IF PSUNDC=""
SET PSUNDC="No NDC"
+4 IF PSUNFI=1
SET PSUNFI="N/F"
+5 SET (PSIVNFI,PSIVNFR)=""
+6 IF $$VERSION^XPDUTL("PSN")'<4
Begin DoDot:1
+7 SET PSIVNFI=$$FORMI^PSNAPIS(PSUNADR,PSUNDCL)
+8 SET PSIVNFR=$$FORMR^PSNAPIS(PSUNADR,PSUNDCL)>0
End DoDot:1
+9 QUIT
CALC ;Do calculations for additives and solutions
+1 SET ^XTMP(PSUIVSUB,"CST",PSUFAC)=(PSUNITS*PSUDCST)+$GET(^XTMP(PSUIVSUB,"CST",PSUFAC))
+2 SET RECTYP=""
+3 SET COUNT=COUNT+1
+4 if COUNT=1
SET RECTYP="P"
+5 IF PSUOUTP="Y"
Begin DoDot:1
+6 SET ^XTMP(PSUIVSUB,"OCST",PSUFAC)=(PSUDCST*PSUBAGS)+$GET(^XTMP(PSUIVSUB,"OCST",PSUFAC))
End DoDot:1
+7 IF PSUIV(.04)="P"
Begin DoDot:1
+8 SET ^XTMP(PSUIVSUB,"SPIG",PSUFAC)=(PSUDCST*PSUBAGS)+$GET(^XTMP(PSUIVSUB,"SPIG",PSUFAC))
End DoDot:1
+9 IF PSUIV(.04)="A"
Begin DoDot:1
+10 SET ^XTMP(PSUIVSUB,"SADM",PSUFAC)=(PSUDCST*PSUBAGS)+$GET(^XTMP(PSUIVSUB,"SADM",PSUFAC))
End DoDot:1
+11 IF PSUIV(.04)="H"
Begin DoDot:1
+12 SET ^XTMP(PSUIVSUB,"SHYP",PSUFAC)=(PSUDCST*PSUBAGS)+$GET(^XTMP(PSUIVSUB,"SHYP",PSUFAC))
End DoDot:1
+13 IF PSUIV(.04)="S"
Begin DoDot:1
+14 SET ^XTMP(PSUIVSUB,"SSYR",PSUFAC)=(PSUDCST*PSUBAGS)+$GET(^XTMP(PSUIVSUB,"SSYR",PSUFAC))
End DoDot:1
+15 IF PSUIV(.04)="C"
Begin DoDot:1
+16 SET ^XTMP(PSUIVSUB,"SCHEM",PSUFAC)=(PSUDCST*PSUBAGS)+$GET(^XTMP(PSUIVSUB,"SCHEM",PSUFAC))
End DoDot:1
+17 QUIT
