188 lines
4.7 KiB
Mathematica
188 lines
4.7 KiB
Mathematica
PSUV8 ;BIR/DAM - IV TPN AMIS Summary Data ;11 March 2004
|
|
;;4.0;PHARMACY BENEFITS MANAGEMENT;**4**;MARCH, 2005
|
|
;
|
|
;This routine gathers IV TPN AMIS summary data
|
|
;No DBIA's needed
|
|
;
|
|
EN ;Entry point to gather AMIS data. Called from PSUV3
|
|
;
|
|
K PSUIVA ;Array to hold temporary data
|
|
;
|
|
;Initialize variables for column totals
|
|
;
|
|
;
|
|
S PSUDIV=0
|
|
S PSUCT=0
|
|
F S PSUDIV=$O(^XTMP(PSUIVSUB,"RECORDS",PSUDIV)) Q:PSUDIV="" D EN1
|
|
Q
|
|
;
|
|
EN1 ;EN CONTINUED
|
|
;
|
|
S PSUOR=""
|
|
N LDSP,LREC,LDES,CLAN,NDSP,LTOT,CNDSP
|
|
F S PSUCT=$O(^XTMP(PSUIVSUB,"RECORDS",PSUDIV,PSUCT)) Q:PSUCT="" D
|
|
.K PSUAMIS
|
|
.M PSUAMIS(PSUDIV,PSUCT)=^XTMP(PSUIVSUB,"RECORDS",PSUDIV,PSUCT)
|
|
.;
|
|
.S PSUP=""
|
|
.S PSUP=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,5) ;parent record
|
|
.;
|
|
.S PSUTYP=""
|
|
.S PSUTYP=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,6) ;IV TYPE
|
|
.;
|
|
.I PSUTYP="H" S PSUOR=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,4) ;IV order #
|
|
.D LVPDSP
|
|
.D LVPREC
|
|
.D LVPDES
|
|
.D LVPCAN
|
|
.D LVPNET
|
|
.D LVPTOT
|
|
.D CNET
|
|
.D REC
|
|
D TOTAL
|
|
;
|
|
Q
|
|
;
|
|
LVPDSP ;Gather TPN Dispensed data
|
|
;
|
|
I PSUTYP="H",PSUP="P" D ;TPNs Dispensed
|
|
.N DSP
|
|
.S DSP=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,29)
|
|
.S $P(PSUIVA(PSUDIV),U,1)=$P($G(PSUIVA(PSUDIV)),U,1)+DSP
|
|
;
|
|
Q
|
|
;
|
|
LVPREC ;Gather TPN Recycled data
|
|
;
|
|
I PSUTYP="H",PSUP="P" D ;TPN's recycled
|
|
.N REC
|
|
.S REC=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,30)
|
|
.S $P(PSUIVA(PSUDIV),U,2)=$P($G(PSUIVA(PSUDIV)),U,2)+REC
|
|
;
|
|
Q
|
|
;
|
|
LVPDES ;Gather TPN Destroyed data
|
|
;
|
|
I PSUTYP="H",PSUP="P" D ;TPN's destroyed
|
|
.N DES
|
|
.S DES=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,31)
|
|
.S $P(PSUIVA(PSUDIV),U,3)=$P($G(PSUIVA(PSUDIV)),U,3)+DES
|
|
;
|
|
Q
|
|
;
|
|
LVPCAN ;Gather TPN Cancelled data
|
|
;
|
|
I PSUTYP="H",PSUP="P" D ;TPN's cancelled
|
|
.N CAN
|
|
.S CAN=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,32)
|
|
.S $P(PSUIVA(PSUDIV),U,4)=$P($G(PSUIVA(PSUDIV)),U,4)+CAN
|
|
;
|
|
Q
|
|
;
|
|
LVPNET ;Calculate net amount of TPN's Dispensed
|
|
;
|
|
;
|
|
I PSUTYP="H",PSUP="P" D
|
|
.N NET
|
|
.S NET=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,11)
|
|
.S $P(PSUIVA(PSUDIV),U,5)=$P($G(PSUIVA(PSUDIV)),U,5)+NET
|
|
Q
|
|
;
|
|
LVPTOT ;Calculate Total cost
|
|
;
|
|
N NDIS,COST,PSUOR1
|
|
S PSUCTA=0
|
|
F S PSUCTA=$O(PSUAMIS(PSUDIV,PSUCTA)) Q:PSUCTA="" D
|
|
.S PSUOR1=$P(PSUAMIS(PSUDIV,PSUCTA),U,4)
|
|
.Q:(PSUOR1'=PSUOR)
|
|
.S NDIS=$P($G(PSUAMIS(PSUDIV,PSUCTA)),U,33)
|
|
.S COST=$P($G(PSUAMIS(PSUDIV,PSUCTA)),U,22)
|
|
.S $P(PSUIVA(PSUDIV),U,6)=$P($G(PSUIVA(PSUDIV)),U,6)+(NDIS*$G(COST))
|
|
.;
|
|
.;Truncate cost to 2 decimal places
|
|
.N A,B,C
|
|
.;
|
|
.I $P(PSUIVA(PSUDIV),U,6)'["." D Q
|
|
..S $P(PSUIVA(PSUDIV),U,6)=$P(PSUIVA(PSUDIV),U,6)_".00"
|
|
.;
|
|
.S A=$F($P(PSUIVA(PSUDIV),U,6),".") ;Find 1st position after decimal
|
|
.;
|
|
.S B=$E($P(PSUIVA(PSUDIV),U,6),1,(A-1)) ;Extract dollars and decimal
|
|
.;
|
|
.S C=$E($P(PSUIVA(PSUDIV),U,6),A,(A+1)) ;Extract cents after decimal
|
|
.I $L(C)'=2 S C=$E(C,1)_0
|
|
.;
|
|
.S $P(PSUIVA(PSUDIV),U,6)=B_C
|
|
Q
|
|
;
|
|
CNET ;Calculate Cost per Net TPN's dispensed
|
|
;
|
|
N CNET,TCOST
|
|
;
|
|
S CNET=$P($G(PSUIVA(PSUDIV)),U,5)
|
|
S TCOST=$P($G(PSUIVA(PSUDIV)),U,6)
|
|
;
|
|
I CNET'="",CNET'=0,TCOST'="" D
|
|
.S $P(PSUIVA(PSUDIV),U,7)=TCOST/CNET
|
|
.;
|
|
.;Truncate cost to 2 decimal places
|
|
.N A,B,C
|
|
.;
|
|
.I $P(PSUIVA(PSUDIV),U,7)'["." D Q
|
|
..S $P(PSUIVA(PSUDIV),U,7)=$P(PSUIVA(PSUDIV),U,7)_".00"
|
|
.;
|
|
.S A=$F($P(PSUIVA(PSUDIV),U,7),".") ;Find 1st position after decimal
|
|
.;
|
|
.S B=$E($P(PSUIVA(PSUDIV),U,7),1,(A-1)) ;Extract dollars and decimal
|
|
.;
|
|
.S C=$E($P(PSUIVA(PSUDIV),U,7),A,(A+1)) ;Extract cents after decimal
|
|
.I $L(C)'=2 S C=$E(C,1)_0
|
|
.;
|
|
.S $P(PSUIVA(PSUDIV),U,7)=B_C
|
|
;
|
|
Q
|
|
;
|
|
TOTAL ;Add up column totals and place into ^XTMP global
|
|
;
|
|
S PSUDI=0
|
|
F S PSUDI=$O(PSUIVA(PSUDI)) Q:PSUDI="" D
|
|
.S LDSP=$G(LDSP)+$P(PSUIVA(PSUDI),U,1) ;Total TPN's dispensed
|
|
.;
|
|
.S LREC=$G(LREC)+$P(PSUIVA(PSUDI),U,2) ;Total TPN's recycled
|
|
.;
|
|
.S LDES=$G(LDES)+$P(PSUIVA(PSUDI),U,3) ;Total TPN's destroyed
|
|
.;
|
|
.S CLAN=$G(CLAN)+$P(PSUIVA(PSUDI),U,4) ;Total TPN's cancelled
|
|
.;
|
|
.S NDSP=$G(NDSP)+$P(PSUIVA(PSUDI),U,5) ;Total Net TPN's dispensed
|
|
.;
|
|
.S LTOT=$G(LTOT)+$P(PSUIVA(PSUDI),U,6) ;Total of Total cost
|
|
.;
|
|
.;S CNDSP=$G(CNDSP)+$P(PSUIVA(PSUDI),U,7) ;Total of cost/net column
|
|
.I $G(NDSP) S CNDSP=$G(LTOT)/NDSP D
|
|
..I CNDSP'["." S CNDSP=CNDSP_".00" Q
|
|
..N A,B,C
|
|
..S A=$F(CNDSP,".") ;Find 1st position after decimal
|
|
..S B=$E(CNDSP,1,(A-1)) ;Extract dollars and decimal
|
|
..S C=$E(CNDSP,A,(A+1)) ;Extract cents after decimal
|
|
..I $L(C)'=2 S C=$E(C,1)_0
|
|
..S CNDSP=B_C
|
|
;
|
|
I '$D(LDSP) S LDSP=0
|
|
I '$D(LREC) S LREC=0
|
|
I '$D(LDES) S LDES=0
|
|
I '$D(CLAN) S CLAN=0
|
|
I '$D(NDSP) S NDSP=0
|
|
I '$D(LTOT) S LTOT="0.00"
|
|
I '$D(CNDSP) S CNDSP="0.00"
|
|
;
|
|
S ^XTMP(PSUIVSUB,"TPNTOT")=$G(LDSP)_U_$G(LREC)_U_$G(LDES)_U_$G(CLAN)_U_$G(NDSP)_U_$G(LTOT)_U_$G(CNDSP)
|
|
;
|
|
Q
|
|
;
|
|
REC ;Place contents of arrays into ^XTMP globals
|
|
;
|
|
M ^XTMP(PSUIVSUB,"TPN",PSUDIV)=PSUIVA(PSUDIV) ;TPN RECORDS
|
|
;
|
|
Q
|