PSUV2 ;BIR/CFL - IV functions and subroutines ;25 AUG 1998
;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
;
;DBIA'S
;Reference to file #2 supported by DBIA 10035 and 2701
;
GETRATE(TYPE) ;Determine if the IV type is schedule or infusion rate and calculate the subtotal of each type
S PSURATE=""
I TYPE="P" D
.S PSURATE=PSUIV(.09)
.S ^XTMP(PSUIVSUB,"TPIG",PSUFAC)=$G(^XTMP(PSUIVSUB,"TPIG",PSUFAC))+PSUDISP
I TYPE="A" D
.S PSURATE=PSUIV(.08)
.S ^XTMP(PSUIVSUB,"TADM",PSUFAC)=$G(^XTMP(PSUIVSUB,"TADM",PSUFAC))+PSUDISP
I TYPE="H" D
.S PSURATE=PSUIV(.08)
.S ^XTMP(PSUIVSUB,"THYP",PSUFAC)=$G(^XTMP(PSUIVSUB,"THYP",PSUFAC))+PSUDISP
I TYPE="S"&(PSUIV(108)=1) D
.S PSURATE=PSUIV(.09)
.S ^XTMP(PSUIVSUB,"TSYR",PSUFAC)=$G(^XTMP(PSUIVSUB,"TSYR",PSUFAC))+PSUDISP
I TYPE="S"&(PSUIV(108)=0) D
.S PSURATE=PSUIV(.08)
.S ^XTMP(PSUIVSUB,"TSYR",PSUFAC)=$G(^XTMP(PSUIVSUB,"TSYR",PSUFAC))+PSUDISP
I TYPE="C"&(PSUIV(106)="P") D
.S PSURATE=PSUIV(.09)
.S ^XTMP(PSUIVSUB,"TCHEM",PSUFAC)=$G(^XTMP(PSUIVSUB,"TCHEM",PSUFAC))+PSUDISP
I TYPE="C"&(PSUIV(106)="A") D
.S PSURATE=PSUIV(.08)
.S ^XTMP(PSUIVSUB,"TCHEM",PSUFAC)=$G(^XTMP(PSUIVSUB,"TCHEM",PSUFAC))+PSUDISP
I TYPE="C"&(PSUIV(106)="S")&(PSUIV(108)=1) D
.S PSURATE=PSUIV(.09)
.S ^XTMP(PSUIVSUB,"TCHEM",PSUFAC)=$G(^XTMP(PSUIVSUB,"TCHEM",PSUFAC))+PSUDISP
I TYPE="C"&(PSUIV(106)="S")&(PSUIV(108)=0) D
.S PSURATE=PSUIV(.08)
.S ^XTMP(PSUIVSUB,"TCHEM",PSUFAC)=$G(^XTMP(PSUIVSUB,"TCHEM",PSUFAC))+PSUDISP
Q
SETREC ;Set the ^XTMP global for IV Additives and Solutions
S REC="^",DLM="^",INDEX=""
I RECTYP="P" D ;Record type of "P" indicates parent record.
.S REC=REC_$TR(PSUFAC,"^","'")_DLM_$TR(PSUIV(.02),"^","'")_DLM_PSUIV(.01)_DLM
.S REC=REC_RECTYP_DLM_$TR(PSUIV(.04),"^","'")_DLM_PSUOUTP_DLM_PSUSSN_DLM
.S REC=REC_$G(PSURATE)_DLM_$TR(PSUDOC(9),"^","'")_DLM ;_$TR(PSUPCLS,"^","'")_DLM
.S REC=REC_$TR(PSUDISP,"^","'")_DLM_$TR(PSUPRNM,"^","'")_DLM
.S REC=REC_$TR(PSUDCLS,"^","'")_DLM_$TR(PSUNDC,"^","'")_DLM
.S REC=REC_$TR(PSUNFI,"^","'")_DLM_$TR(PSIVNFI,"^","'")_DLM
.S REC=REC_$TR(PSIVNFR,"^","'")_DLM_$TR(PSUPNAM,"^","'")_DLM
.S REC=REC_RECIND_DLM_$TR(PSUGNM,"^","'")_DLM_$TR(PSUDGU,"^","'")_DLM
.S REC=REC_PSUDCST_DLM_PSUNITS_DLM_PSUNAF_DLM_PSUDEA_DLM
.D ICN
.;VMP - OIFO BAY PINES;ELR;PSU*3.0*24
.S PSUPICN=$G(^XTMP("PSU_"_PSUJOB,"PSUPICN"))
.S REC=REC_$G(PSUPICN)_DLM_$G(PSUIV(.06))_DLM_$G(PSUIV(.03))_U
.;
.;DAM..ADD PHASE II NEW PIECES HERE
.I $G(PSUDISPT) S REC=REC_PSUDISPT_U ;#IV bags dispensed
.I '$G(PSUDISPT) S REC=REC_0_U
.;
.I $G(PSURECT) S REC=REC_PSURECT_U ;#IV bags recycled
.I '$G(PSURECT) S REC=REC_0_U
.;
.I $G(PSUDEST) S REC=REC_PSUDEST_U ;#IV bags destroyed
.I '$G(PSUDEST) S REC=REC_0_U
.;
.I $G(PSUCAN) S REC=REC_PSUCAN_U ;#IV bags cancelled
.I '$G(PSUCAN) S REC=REC_0_U
.;
.I $G(PSUTDSP1) S REC=REC_PSUTDSP1_U ;Total units dispensed
.I '$G(PSUTDSP1) S REC=REC_0_U
.I $G(PSURCY1) S REC=REC_PSURCY1_U ;Total units recycled
.I '$G(PSURCY1) S REC=REC_0_U
.I $G(PSUDES1) S REC=REC_PSUDES1_U ;Total units destroyed
.I '$G(PSUDES1) S REC=REC_0_U
.I $G(PSUCAN1) S REC=REC_PSUCAN1_U ;Total units cancelled
.I '$G(PSUCAN1) S REC=REC_0_U
.;END DAM
.;
.S INDEX=$O(^XTMP(PSUIVSUB,"RECORDS",PSUFAC,INDEX),-1)
.S INDEX=INDEX+1
.S ^XTMP(PSUIVSUB,"RECORDS",PSUFAC,INDEX)=REC
I RECTYP'="P" D
.S REC=REC_$TR(PSUFAC,"^","'")_DLM_$TR(PSUIV(.02),"^","'")_DLM_PSUIV(.01)_DLM
.S REC=REC_DLM_DLM_DLM_PSUSSN_DLM
.S REC=REC_$G(PSURATE)_DLM_$TR(PSUDOC(9),"^","'")_DLM ;_$TR(PSUPCLS,"^","'")_DLM
.;S REC=REC_$TR(PSUSERV,"^","'")_DLM_$TR(PSUSP1,"^","'")_DLM_$TR(PSUSP2,"^","'")_DLM
.S REC=REC_DLM_$TR(PSUPRNM,"^","'")_DLM
.S REC=REC_$TR(PSUDCLS,"^","'")_DLM_$TR(PSUNDC,"^","'")_DLM
.S REC=REC_$TR(PSUNFI,"^","'")_DLM_$TR(PSIVNFI,"^","'")_DLM
.S REC=REC_$TR(PSIVNFR,"^","'")_DLM_$TR(PSUPNAM,"^","'")_DLM
.S REC=REC_RECIND_DLM_$TR(PSUGNM,"^","'")_DLM_$TR(PSUDGU,"^","'")_DLM
.S REC=REC_PSUDCST_DLM_PSUNITS_DLM_PSUNAF_DLM_PSUDEA_DLM
.S REC=REC_$G(PSUPICN)_DLM_$G(PSUDIEN)_DLM_$G(PSUIV(.03))_U
.;
.;New AMIS Additive/Solution code set here DAM
.S REC=REC_U_U_U_U ;sets pieces 29 through 32 to null
.I RECIND="A" D ;Additives
..I $G(PSUTDSP1) S REC=REC_PSUTDSP1_U ;Total units dispensed
..I '$G(PSUTDSP1) S REC=REC_0_U
..I $G(PSURCY1) S REC=REC_PSURCY1_U ;Total units recycled
..I '$G(PSURCY1) S REC=REC_0_U
..I $G(PSUDES1) S REC=REC_PSUDES1_U ;Total units destroyed
..I '$G(PSUDES1) S REC=REC_0_U
..I $G(PSUCAN1) S REC=REC_PSUCAN1_U ;Total units cancelled
..I '$G(PSUCAN1) S REC=REC_0_U
.;
.I RECIND="S" D ;Solutions
..I $G(PSUTSOL1) S REC=REC_PSUTSOL1_U ;Total units dispensed
..I '$G(PSUTSOL1) S REC=REC_0_U
..I $G(PSUTRS1) S REC=REC_PSUTRS1_U ;Total units recycled
..I '$G(PSUTRS1) S REC=REC_0_U
..I $G(PSUTDS1) S REC=REC_PSUTDS1_U ;Total units destroyed
..I '$G(PSUTDS1) S REC=REC_0_U
..I $G(PSUTCS1) S REC=REC_PSUTCS1_U ;Total units cancelled
..I '$G(PSUTCS1) S REC=REC_0_U
.;End DAM
.;
.I '$D(^XTMP(PSUIVSUB,"RECORDS",PSUFAC)) S INDEX=0
.S INDEX=$O(^XTMP(PSUIVSUB,"RECORDS",PSUFAC,INDEX),-1)
.S INDEX=INDEX+1
.S ^XTMP(PSUIVSUB,"RECORDS",PSUFAC,INDEX)=REC
D LAB^PSULR0("IV",PSUFAC,PSUODA,PSUPDA,PSUGNM,PSUDCLS)
Q
SETDRUG ;Set the ^XTMP global for the drug distribution report
S REC=""
I '$D(^XTMP(PSUIVSUB,"DRUG",PSUFAC,PSUGNM)) S ^XTMP(PSUIVSUB,"DRUG",PSUFAC,PSUGNM)=""
S DATA=^XTMP(PSUIVSUB,"DRUG",PSUFAC,PSUGNM)
S REC=PSUDGU_U_(PSUNITS+$P(DATA,"^",2))
S REC=REC_U_(PSUDISP+$P(DATA,"^",3))_U_PSUNFI_U_PSIVNFI
S ^XTMP(PSUIVSUB,"DRUG",PSUFAC,PSUGNM)=REC
Q
SETSUM ;Set the ^XTMP global for the summary information
S PSUFAC=""
F S PSUFAC=$O(PSUFAC(PSUFAC)) Q:PSUFAC="" D
.S PSUTORD=$G(^XTMP(PSUIVSUB,"ORD",PSUFAC),0)
.S PSUTPAT=$G(^XTMP(PSUIVSUB,"SSN",PSUFAC),0)
.S PSUTCST=$G(^XTMP(PSUIVSUB,"CST",PSUFAC),0)
.S PSUTOP=$G(^XTMP(PSUIVSUB,"OORD",PSUFAC),0)
.S PSUODSP=$G(^XTMP(PSUIVSUB,"ODISP",PSUFAC),0)
.S PSUOCST=$G(^XTMP(PSUIVSUB,"OCST",PSUFAC),0)
.S PSUTPIG=$G(^XTMP(PSUIVSUB,"TPIG",PSUFAC),0)
.S PSUTSYR=$G(^XTMP(PSUIVSUB,"TSYR",PSUFAC),0)
.S PSUTHYP=$G(^XTMP(PSUIVSUB,"THYP",PSUFAC),0)
.S PSUTADM=$G(^XTMP(PSUIVSUB,"TADM",PSUFAC),0)
.S PSUTCHEM=$G(^XTMP(PSUIVSUB,"TCHEM",PSUFAC),0)
.S PSUSPIG=$G(^XTMP(PSUIVSUB,"SPIG",PSUFAC),0)
.S PSUSSYR=$G(^XTMP(PSUIVSUB,"SSYR",PSUFAC),0)
.S PSUSHYP=$G(^XTMP(PSUIVSUB,"SHYP",PSUFAC),0)
.S PSUSADM=$G(^XTMP(PSUIVSUB,"SADM",PSUFAC),0)
.S PSUSCHEM=$G(^XTMP(PSUIVSUB,"SCHEM",PSUFAC),0)
.S PSUBPIG=$G(^XTMP(PSUIVSUB,"TYPE_P",PSUFAC),0)
.S PSUBSYR=$G(^XTMP(PSUIVSUB,"TYPE_S",PSUFAC),0)
.S PSUBHYP=$G(^XTMP(PSUIVSUB,"TYPE_H",PSUFAC),0)
.S PSUBADM=$G(^XTMP(PSUIVSUB,"TYPE_A",PSUFAC),0)
.S PSUBCHEM=$G(^XTMP(PSUIVSUB,"TYPE_C",PSUFAC),0)
.S PSUAPIG=$S(PSUBPIG:PSUSPIG/PSUBPIG,1:"")
.S PSUASYR=$S(PSUBSYR:PSUSSYR/PSUBSYR,1:"")
.S PSUAHYP=$S(PSUBHYP:PSUSHYP/PSUBHYP,1:"")
.S PSUAADM=$S(PSUBADM:PSUSADM/PSUBADM,1:"")
.S PSUACHEM=$S(PSUBCHEM:PSUSCHEM/PSUBCHEM,1:"")
.S PSUTBAGS=PSUBPIG+PSUBSYR+PSUBHYP+PSUBADM+PSUBCHEM
.S REC=PSUTORD_U_PSUTPAT_U_PSUTBAGS_U_$J(PSUTCST,0,2)_U_PSUTOP_U
.S REC=REC_PSUODSP_U_$J(PSUOCST,0,2)_U_PSUBPIG_U_$J(PSUAPIG,0,2)
.S REC=REC_U_PSUBHYP_U_$J(PSUAHYP,0,2)_U_PSUBADM_U_$J(PSUAADM,0,2)
.S REC=REC_U_PSUBCHEM_U_$J(PSUACHEM,0,2)_U_PSUBSYR_U_$J(PSUASYR,0,2)
.S ^XTMP(PSUIVSUB,"SUMMARY",PSUFAC,0)=REC
.S PSUDIV=PSUFAC D GETDIV^PSUV3 I PSUDIVNM'="" D
..S ^XTMP("PSU_"_PSUJOB,"PSUCT",PSUDIVNM)=PSUTPAT
.I PSUDIVNM="" S ^XTMP("PSU_"_PSUJOB,"PSUCT",PSUDIV)=PSUTPAT
Q
;
ICN ;Find patient ICN
;VMP OIFO BAY PINES;ELR;PSU*3.0*24
;
N PSUPICN,PSUPICN1,PSUICN
I $G(PSUSSN),PSUSSN'="" D
.S PSUPTN=0
.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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUV2 8130 printed Oct 16, 2024@18:29:31 Page 2
PSUV2 ;BIR/CFL - IV functions and subroutines ;25 AUG 1998
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
+2 ;
+3 ;DBIA'S
+4 ;Reference to file #2 supported by DBIA 10035 and 2701
+5 ;
GETRATE(TYPE) ;Determine if the IV type is schedule or infusion rate and calculate the subtotal of each type
+1 SET PSURATE=""
+2 IF TYPE="P"
Begin DoDot:1
+3 SET PSURATE=PSUIV(.09)
+4 SET ^XTMP(PSUIVSUB,"TPIG",PSUFAC)=$GET(^XTMP(PSUIVSUB,"TPIG",PSUFAC))+PSUDISP
End DoDot:1
+5 IF TYPE="A"
Begin DoDot:1
+6 SET PSURATE=PSUIV(.08)
+7 SET ^XTMP(PSUIVSUB,"TADM",PSUFAC)=$GET(^XTMP(PSUIVSUB,"TADM",PSUFAC))+PSUDISP
End DoDot:1
+8 IF TYPE="H"
Begin DoDot:1
+9 SET PSURATE=PSUIV(.08)
+10 SET ^XTMP(PSUIVSUB,"THYP",PSUFAC)=$GET(^XTMP(PSUIVSUB,"THYP",PSUFAC))+PSUDISP
End DoDot:1
+11 IF TYPE="S"&(PSUIV(108)=1)
Begin DoDot:1
+12 SET PSURATE=PSUIV(.09)
+13 SET ^XTMP(PSUIVSUB,"TSYR",PSUFAC)=$GET(^XTMP(PSUIVSUB,"TSYR",PSUFAC))+PSUDISP
End DoDot:1
+14 IF TYPE="S"&(PSUIV(108)=0)
Begin DoDot:1
+15 SET PSURATE=PSUIV(.08)
+16 SET ^XTMP(PSUIVSUB,"TSYR",PSUFAC)=$GET(^XTMP(PSUIVSUB,"TSYR",PSUFAC))+PSUDISP
End DoDot:1
+17 IF TYPE="C"&(PSUIV(106)="P")
Begin DoDot:1
+18 SET PSURATE=PSUIV(.09)
+19 SET ^XTMP(PSUIVSUB,"TCHEM",PSUFAC)=$GET(^XTMP(PSUIVSUB,"TCHEM",PSUFAC))+PSUDISP
End DoDot:1
+20 IF TYPE="C"&(PSUIV(106)="A")
Begin DoDot:1
+21 SET PSURATE=PSUIV(.08)
+22 SET ^XTMP(PSUIVSUB,"TCHEM",PSUFAC)=$GET(^XTMP(PSUIVSUB,"TCHEM",PSUFAC))+PSUDISP
End DoDot:1
+23 IF TYPE="C"&(PSUIV(106)="S")&(PSUIV(108)=1)
Begin DoDot:1
+24 SET PSURATE=PSUIV(.09)
+25 SET ^XTMP(PSUIVSUB,"TCHEM",PSUFAC)=$GET(^XTMP(PSUIVSUB,"TCHEM",PSUFAC))+PSUDISP
End DoDot:1
+26 IF TYPE="C"&(PSUIV(106)="S")&(PSUIV(108)=0)
Begin DoDot:1
+27 SET PSURATE=PSUIV(.08)
+28 SET ^XTMP(PSUIVSUB,"TCHEM",PSUFAC)=$GET(^XTMP(PSUIVSUB,"TCHEM",PSUFAC))+PSUDISP
End DoDot:1
+29 QUIT
SETREC ;Set the ^XTMP global for IV Additives and Solutions
+1 SET REC="^"
SET DLM="^"
SET INDEX=""
+2 ;Record type of "P" indicates parent record.
IF RECTYP="P"
Begin DoDot:1
+3 SET REC=REC_$TRANSLATE(PSUFAC,"^","'")_DLM_$TRANSLATE(PSUIV(.02),"^","'")_DLM_PSUIV(.01)_DLM
+4 SET REC=REC_RECTYP_DLM_$TRANSLATE(PSUIV(.04),"^","'")_DLM_PSUOUTP_DLM_PSUSSN_DLM
+5 ;_$TR(PSUPCLS,"^","'")_DLM
SET REC=REC_$GET(PSURATE)_DLM_$TRANSLATE(PSUDOC(9),"^","'")_DLM
+6 SET REC=REC_$TRANSLATE(PSUDISP,"^","'")_DLM_$TRANSLATE(PSUPRNM,"^","'")_DLM
+7 SET REC=REC_$TRANSLATE(PSUDCLS,"^","'")_DLM_$TRANSLATE(PSUNDC,"^","'")_DLM
+8 SET REC=REC_$TRANSLATE(PSUNFI,"^","'")_DLM_$TRANSLATE(PSIVNFI,"^","'")_DLM
+9 SET REC=REC_$TRANSLATE(PSIVNFR,"^","'")_DLM_$TRANSLATE(PSUPNAM,"^","'")_DLM
+10 SET REC=REC_RECIND_DLM_$TRANSLATE(PSUGNM,"^","'")_DLM_$TRANSLATE(PSUDGU,"^","'")_DLM
+11 SET REC=REC_PSUDCST_DLM_PSUNITS_DLM_PSUNAF_DLM_PSUDEA_DLM
+12 DO ICN
+13 ;VMP - OIFO BAY PINES;ELR;PSU*3.0*24
+14 SET PSUPICN=$GET(^XTMP("PSU_"_PSUJOB,"PSUPICN"))
+15 SET REC=REC_$GET(PSUPICN)_DLM_$GET(PSUIV(.06))_DLM_$GET(PSUIV(.03))_U
+16 ;
+17 ;DAM..ADD PHASE II NEW PIECES HERE
+18 ;#IV bags dispensed
IF $GET(PSUDISPT)
SET REC=REC_PSUDISPT_U
+19 IF '$GET(PSUDISPT)
SET REC=REC_0_U
+20 ;
+21 ;#IV bags recycled
IF $GET(PSURECT)
SET REC=REC_PSURECT_U
+22 IF '$GET(PSURECT)
SET REC=REC_0_U
+23 ;
+24 ;#IV bags destroyed
IF $GET(PSUDEST)
SET REC=REC_PSUDEST_U
+25 IF '$GET(PSUDEST)
SET REC=REC_0_U
+26 ;
+27 ;#IV bags cancelled
IF $GET(PSUCAN)
SET REC=REC_PSUCAN_U
+28 IF '$GET(PSUCAN)
SET REC=REC_0_U
+29 ;
+30 ;Total units dispensed
IF $GET(PSUTDSP1)
SET REC=REC_PSUTDSP1_U
+31 IF '$GET(PSUTDSP1)
SET REC=REC_0_U
+32 ;Total units recycled
IF $GET(PSURCY1)
SET REC=REC_PSURCY1_U
+33 IF '$GET(PSURCY1)
SET REC=REC_0_U
+34 ;Total units destroyed
IF $GET(PSUDES1)
SET REC=REC_PSUDES1_U
+35 IF '$GET(PSUDES1)
SET REC=REC_0_U
+36 ;Total units cancelled
IF $GET(PSUCAN1)
SET REC=REC_PSUCAN1_U
+37 IF '$GET(PSUCAN1)
SET REC=REC_0_U
+38 ;END DAM
+39 ;
+40 SET INDEX=$ORDER(^XTMP(PSUIVSUB,"RECORDS",PSUFAC,INDEX),-1)
+41 SET INDEX=INDEX+1
+42 SET ^XTMP(PSUIVSUB,"RECORDS",PSUFAC,INDEX)=REC
End DoDot:1
+43 IF RECTYP'="P"
Begin DoDot:1
+44 SET REC=REC_$TRANSLATE(PSUFAC,"^","'")_DLM_$TRANSLATE(PSUIV(.02),"^","'")_DLM_PSUIV(.01)_DLM
+45 SET REC=REC_DLM_DLM_DLM_PSUSSN_DLM
+46 ;_$TR(PSUPCLS,"^","'")_DLM
SET REC=REC_$GET(PSURATE)_DLM_$TRANSLATE(PSUDOC(9),"^","'")_DLM
+47 ;S REC=REC_$TR(PSUSERV,"^","'")_DLM_$TR(PSUSP1,"^","'")_DLM_$TR(PSUSP2,"^","'")_DLM
+48 SET REC=REC_DLM_$TRANSLATE(PSUPRNM,"^","'")_DLM
+49 SET REC=REC_$TRANSLATE(PSUDCLS,"^","'")_DLM_$TRANSLATE(PSUNDC,"^","'")_DLM
+50 SET REC=REC_$TRANSLATE(PSUNFI,"^","'")_DLM_$TRANSLATE(PSIVNFI,"^","'")_DLM
+51 SET REC=REC_$TRANSLATE(PSIVNFR,"^","'")_DLM_$TRANSLATE(PSUPNAM,"^","'")_DLM
+52 SET REC=REC_RECIND_DLM_$TRANSLATE(PSUGNM,"^","'")_DLM_$TRANSLATE(PSUDGU,"^","'")_DLM
+53 SET REC=REC_PSUDCST_DLM_PSUNITS_DLM_PSUNAF_DLM_PSUDEA_DLM
+54 SET REC=REC_$GET(PSUPICN)_DLM_$GET(PSUDIEN)_DLM_$GET(PSUIV(.03))_U
+55 ;
+56 ;New AMIS Additive/Solution code set here DAM
+57 ;sets pieces 29 through 32 to null
SET REC=REC_U_U_U_U
+58 ;Additives
IF RECIND="A"
Begin DoDot:2
+59 ;Total units dispensed
IF $GET(PSUTDSP1)
SET REC=REC_PSUTDSP1_U
+60 IF '$GET(PSUTDSP1)
SET REC=REC_0_U
+61 ;Total units recycled
IF $GET(PSURCY1)
SET REC=REC_PSURCY1_U
+62 IF '$GET(PSURCY1)
SET REC=REC_0_U
+63 ;Total units destroyed
IF $GET(PSUDES1)
SET REC=REC_PSUDES1_U
+64 IF '$GET(PSUDES1)
SET REC=REC_0_U
+65 ;Total units cancelled
IF $GET(PSUCAN1)
SET REC=REC_PSUCAN1_U
+66 IF '$GET(PSUCAN1)
SET REC=REC_0_U
End DoDot:2
+67 ;
+68 ;Solutions
IF RECIND="S"
Begin DoDot:2
+69 ;Total units dispensed
IF $GET(PSUTSOL1)
SET REC=REC_PSUTSOL1_U
+70 IF '$GET(PSUTSOL1)
SET REC=REC_0_U
+71 ;Total units recycled
IF $GET(PSUTRS1)
SET REC=REC_PSUTRS1_U
+72 IF '$GET(PSUTRS1)
SET REC=REC_0_U
+73 ;Total units destroyed
IF $GET(PSUTDS1)
SET REC=REC_PSUTDS1_U
+74 IF '$GET(PSUTDS1)
SET REC=REC_0_U
+75 ;Total units cancelled
IF $GET(PSUTCS1)
SET REC=REC_PSUTCS1_U
+76 IF '$GET(PSUTCS1)
SET REC=REC_0_U
End DoDot:2
+77 ;End DAM
+78 ;
+79 IF '$DATA(^XTMP(PSUIVSUB,"RECORDS",PSUFAC))
SET INDEX=0
+80 SET INDEX=$ORDER(^XTMP(PSUIVSUB,"RECORDS",PSUFAC,INDEX),-1)
+81 SET INDEX=INDEX+1
+82 SET ^XTMP(PSUIVSUB,"RECORDS",PSUFAC,INDEX)=REC
End DoDot:1
+83 DO LAB^PSULR0("IV",PSUFAC,PSUODA,PSUPDA,PSUGNM,PSUDCLS)
+84 QUIT
SETDRUG ;Set the ^XTMP global for the drug distribution report
+1 SET REC=""
+2 IF '$DATA(^XTMP(PSUIVSUB,"DRUG",PSUFAC,PSUGNM))
SET ^XTMP(PSUIVSUB,"DRUG",PSUFAC,PSUGNM)=""
+3 SET DATA=^XTMP(PSUIVSUB,"DRUG",PSUFAC,PSUGNM)
+4 SET REC=PSUDGU_U_(PSUNITS+$PIECE(DATA,"^",2))
+5 SET REC=REC_U_(PSUDISP+$PIECE(DATA,"^",3))_U_PSUNFI_U_PSIVNFI
+6 SET ^XTMP(PSUIVSUB,"DRUG",PSUFAC,PSUGNM)=REC
+7 QUIT
SETSUM ;Set the ^XTMP global for the summary information
+1 SET PSUFAC=""
+2 FOR
SET PSUFAC=$ORDER(PSUFAC(PSUFAC))
if PSUFAC=""
QUIT
Begin DoDot:1
+3 SET PSUTORD=$GET(^XTMP(PSUIVSUB,"ORD",PSUFAC),0)
+4 SET PSUTPAT=$GET(^XTMP(PSUIVSUB,"SSN",PSUFAC),0)
+5 SET PSUTCST=$GET(^XTMP(PSUIVSUB,"CST",PSUFAC),0)
+6 SET PSUTOP=$GET(^XTMP(PSUIVSUB,"OORD",PSUFAC),0)
+7 SET PSUODSP=$GET(^XTMP(PSUIVSUB,"ODISP",PSUFAC),0)
+8 SET PSUOCST=$GET(^XTMP(PSUIVSUB,"OCST",PSUFAC),0)
+9 SET PSUTPIG=$GET(^XTMP(PSUIVSUB,"TPIG",PSUFAC),0)
+10 SET PSUTSYR=$GET(^XTMP(PSUIVSUB,"TSYR",PSUFAC),0)
+11 SET PSUTHYP=$GET(^XTMP(PSUIVSUB,"THYP",PSUFAC),0)
+12 SET PSUTADM=$GET(^XTMP(PSUIVSUB,"TADM",PSUFAC),0)
+13 SET PSUTCHEM=$GET(^XTMP(PSUIVSUB,"TCHEM",PSUFAC),0)
+14 SET PSUSPIG=$GET(^XTMP(PSUIVSUB,"SPIG",PSUFAC),0)
+15 SET PSUSSYR=$GET(^XTMP(PSUIVSUB,"SSYR",PSUFAC),0)
+16 SET PSUSHYP=$GET(^XTMP(PSUIVSUB,"SHYP",PSUFAC),0)
+17 SET PSUSADM=$GET(^XTMP(PSUIVSUB,"SADM",PSUFAC),0)
+18 SET PSUSCHEM=$GET(^XTMP(PSUIVSUB,"SCHEM",PSUFAC),0)
+19 SET PSUBPIG=$GET(^XTMP(PSUIVSUB,"TYPE_P",PSUFAC),0)
+20 SET PSUBSYR=$GET(^XTMP(PSUIVSUB,"TYPE_S",PSUFAC),0)
+21 SET PSUBHYP=$GET(^XTMP(PSUIVSUB,"TYPE_H",PSUFAC),0)
+22 SET PSUBADM=$GET(^XTMP(PSUIVSUB,"TYPE_A",PSUFAC),0)
+23 SET PSUBCHEM=$GET(^XTMP(PSUIVSUB,"TYPE_C",PSUFAC),0)
+24 SET PSUAPIG=$SELECT(PSUBPIG:PSUSPIG/PSUBPIG,1:"")
+25 SET PSUASYR=$SELECT(PSUBSYR:PSUSSYR/PSUBSYR,1:"")
+26 SET PSUAHYP=$SELECT(PSUBHYP:PSUSHYP/PSUBHYP,1:"")
+27 SET PSUAADM=$SELECT(PSUBADM:PSUSADM/PSUBADM,1:"")
+28 SET PSUACHEM=$SELECT(PSUBCHEM:PSUSCHEM/PSUBCHEM,1:"")
+29 SET PSUTBAGS=PSUBPIG+PSUBSYR+PSUBHYP+PSUBADM+PSUBCHEM
+30 SET REC=PSUTORD_U_PSUTPAT_U_PSUTBAGS_U_$JUSTIFY(PSUTCST,0,2)_U_PSUTOP_U
+31 SET REC=REC_PSUODSP_U_$JUSTIFY(PSUOCST,0,2)_U_PSUBPIG_U_$JUSTIFY(PSUAPIG,0,2)
+32 SET REC=REC_U_PSUBHYP_U_$JUSTIFY(PSUAHYP,0,2)_U_PSUBADM_U_$JUSTIFY(PSUAADM,0,2)
+33 SET REC=REC_U_PSUBCHEM_U_$JUSTIFY(PSUACHEM,0,2)_U_PSUBSYR_U_$JUSTIFY(PSUASYR,0,2)
+34 SET ^XTMP(PSUIVSUB,"SUMMARY",PSUFAC,0)=REC
+35 SET PSUDIV=PSUFAC
DO GETDIV^PSUV3
IF PSUDIVNM'=""
Begin DoDot:2
+36 SET ^XTMP("PSU_"_PSUJOB,"PSUCT",PSUDIVNM)=PSUTPAT
End DoDot:2
+37 IF PSUDIVNM=""
SET ^XTMP("PSU_"_PSUJOB,"PSUCT",PSUDIV)=PSUTPAT
End DoDot:1
+38 QUIT
+39 ;
ICN ;Find patient ICN
+1 ;VMP OIFO BAY PINES;ELR;PSU*3.0*24
+2 ;
+3 NEW PSUPICN,PSUPICN1,PSUICN
+4 IF $GET(PSUSSN)
IF PSUSSN'=""
Begin DoDot:1
+5 SET PSUPTN=0
+6 FOR
SET PSUPTN=$ORDER(^DPT("SSN",PSUSSN,PSUPTN))
if PSUPTN=""
QUIT
Begin DoDot:2
+7 SET PSUPICN1=$$GETICN^MPIF001(PSUPTN)
Begin DoDot:3
+8 IF PSUPICN1'[-1
Begin DoDot:4
+9 SET ^XTMP("PSU_"_PSUJOB,"PSUPICN")=PSUPICN1
End DoDot:4
+10 IF PSUPICN1[-1
SET ^XTMP("PSU_"_PSUJOB,"PSUPICN")=""
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT
