- 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
- 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
