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
PSUV8 ;BIR/DAM - IV TPN AMIS Summary Data ;11 March 2004
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**4**;MARCH, 2005
+2 ;
+3 ;This routine gathers IV TPN AMIS summary data
+4 ;No DBIA's needed
+5 ;
EN ;Entry point to gather AMIS data. Called from PSUV3
+1 ;
+2 ;Array to hold temporary data
KILL PSUIVA
+3 ;
+4 ;Initialize variables for column totals
+5 ;
+6 ;
+7 SET PSUDIV=0
+8 SET PSUCT=0
+9 FOR
SET PSUDIV=$ORDER(^XTMP(PSUIVSUB,"RECORDS",PSUDIV))
IF PSUDIV=""
QUIT
DO EN1
+10 QUIT
+11 ;
EN1 ;EN CONTINUED
+1 ;
+2 SET PSUOR=""
+3 NEW LDSP,LREC,LDES,CLAN,NDSP,LTOT,CNDSP
+4 FOR
SET PSUCT=$ORDER(^XTMP(PSUIVSUB,"RECORDS",PSUDIV,PSUCT))
IF PSUCT=""
QUIT
Begin DoDot:1
+5 KILL PSUAMIS
+6 MERGE PSUAMIS(PSUDIV,PSUCT)=^XTMP(PSUIVSUB,"RECORDS",PSUDIV,PSUCT)
+7 ;
+8 SET PSUP=""
+9 ;parent record
SET PSUP=$PIECE($GET(PSUAMIS(PSUDIV,PSUCT)),U,5)
+10 ;
+11 SET PSUTYP=""
+12 ;IV TYPE
SET PSUTYP=$PIECE($GET(PSUAMIS(PSUDIV,PSUCT)),U,6)
+13 ;
+14 ;IV order #
IF PSUTYP="H"
SET PSUOR=$PIECE($GET(PSUAMIS(PSUDIV,PSUCT)),U,4)
+15 DO LVPDSP
+16 DO LVPREC
+17 DO LVPDES
+18 DO LVPCAN
+19 DO LVPNET
+20 DO LVPTOT
+21 DO CNET
+22 DO REC
End DoDot:1
+23 DO TOTAL
+24 ;
+25 QUIT
+26 ;
LVPDSP ;Gather TPN Dispensed data
+1 ;
+2 ;TPNs Dispensed
IF PSUTYP="H"
IF PSUP="P"
Begin DoDot:1
+3 NEW DSP
+4 SET DSP=$PIECE($GET(PSUAMIS(PSUDIV,PSUCT)),U,29)
+5 SET $PIECE(PSUIVA(PSUDIV),U,1)=$PIECE($GET(PSUIVA(PSUDIV)),U,1)+DSP
End DoDot:1
+6 ;
+7 QUIT
+8 ;
LVPREC ;Gather TPN Recycled data
+1 ;
+2 ;TPN's recycled
IF PSUTYP="H"
IF PSUP="P"
Begin DoDot:1
+3 NEW REC
+4 SET REC=$PIECE($GET(PSUAMIS(PSUDIV,PSUCT)),U,30)
+5 SET $PIECE(PSUIVA(PSUDIV),U,2)=$PIECE($GET(PSUIVA(PSUDIV)),U,2)+REC
End DoDot:1
+6 ;
+7 QUIT
+8 ;
LVPDES ;Gather TPN Destroyed data
+1 ;
+2 ;TPN's destroyed
IF PSUTYP="H"
IF PSUP="P"
Begin DoDot:1
+3 NEW DES
+4 SET DES=$PIECE($GET(PSUAMIS(PSUDIV,PSUCT)),U,31)
+5 SET $PIECE(PSUIVA(PSUDIV),U,3)=$PIECE($GET(PSUIVA(PSUDIV)),U,3)+DES
End DoDot:1
+6 ;
+7 QUIT
+8 ;
LVPCAN ;Gather TPN Cancelled data
+1 ;
+2 ;TPN's cancelled
IF PSUTYP="H"
IF PSUP="P"
Begin DoDot:1
+3 NEW CAN
+4 SET CAN=$PIECE($GET(PSUAMIS(PSUDIV,PSUCT)),U,32)
+5 SET $PIECE(PSUIVA(PSUDIV),U,4)=$PIECE($GET(PSUIVA(PSUDIV)),U,4)+CAN
End DoDot:1
+6 ;
+7 QUIT
+8 ;
LVPNET ;Calculate net amount of TPN's Dispensed
+1 ;
+2 ;
+3 IF PSUTYP="H"
IF PSUP="P"
Begin DoDot:1
+4 NEW NET
+5 SET NET=$PIECE($GET(PSUAMIS(PSUDIV,PSUCT)),U,11)
+6 SET $PIECE(PSUIVA(PSUDIV),U,5)=$PIECE($GET(PSUIVA(PSUDIV)),U,5)+NET
End DoDot:1
+7 QUIT
+8 ;
LVPTOT ;Calculate Total cost
+1 ;
+2 NEW NDIS,COST,PSUOR1
+3 SET PSUCTA=0
+4 FOR
SET PSUCTA=$ORDER(PSUAMIS(PSUDIV,PSUCTA))
IF PSUCTA=""
QUIT
Begin DoDot:1
+5 SET PSUOR1=$PIECE(PSUAMIS(PSUDIV,PSUCTA),U,4)
+6 IF (PSUOR1'=PSUOR)
QUIT
+7 SET NDIS=$PIECE($GET(PSUAMIS(PSUDIV,PSUCTA)),U,33)
+8 SET COST=$PIECE($GET(PSUAMIS(PSUDIV,PSUCTA)),U,22)
+9 SET $PIECE(PSUIVA(PSUDIV),U,6)=$PIECE($GET(PSUIVA(PSUDIV)),U,6)+(NDIS*$GET(COST))
+10 ;
+11 ;Truncate cost to 2 decimal places
+12 NEW A,B,C
+13 ;
+14 IF $PIECE(PSUIVA(PSUDIV),U,6)'["."
Begin DoDot:2
+15 SET $PIECE(PSUIVA(PSUDIV),U,6)=$PIECE(PSUIVA(PSUDIV),U,6)_".00"
End DoDot:2
QUIT
+16 ;
+17 ;Find 1st position after decimal
SET A=$FIND($PIECE(PSUIVA(PSUDIV),U,6),".")
+18 ;
+19 ;Extract dollars and decimal
SET B=$EXTRACT($PIECE(PSUIVA(PSUDIV),U,6),1,(A-1))
+20 ;
+21 ;Extract cents after decimal
SET C=$EXTRACT($PIECE(PSUIVA(PSUDIV),U,6),A,(A+1))
+22 IF $LENGTH(C)'=2
SET C=$EXTRACT(C,1)_0
+23 ;
+24 SET $PIECE(PSUIVA(PSUDIV),U,6)=B_C
End DoDot:1
+25 QUIT
+26 ;
CNET ;Calculate Cost per Net TPN's dispensed
+1 ;
+2 NEW CNET,TCOST
+3 ;
+4 SET CNET=$PIECE($GET(PSUIVA(PSUDIV)),U,5)
+5 SET TCOST=$PIECE($GET(PSUIVA(PSUDIV)),U,6)
+6 ;
+7 IF CNET'=""
IF CNET'=0
IF TCOST'=""
Begin DoDot:1
+8 SET $PIECE(PSUIVA(PSUDIV),U,7)=TCOST/CNET
+9 ;
+10 ;Truncate cost to 2 decimal places
+11 NEW A,B,C
+12 ;
+13 IF $PIECE(PSUIVA(PSUDIV),U,7)'["."
Begin DoDot:2
+14 SET $PIECE(PSUIVA(PSUDIV),U,7)=$PIECE(PSUIVA(PSUDIV),U,7)_".00"
End DoDot:2
QUIT
+15 ;
+16 ;Find 1st position after decimal
SET A=$FIND($PIECE(PSUIVA(PSUDIV),U,7),".")
+17 ;
+18 ;Extract dollars and decimal
SET B=$EXTRACT($PIECE(PSUIVA(PSUDIV),U,7),1,(A-1))
+19 ;
+20 ;Extract cents after decimal
SET C=$EXTRACT($PIECE(PSUIVA(PSUDIV),U,7),A,(A+1))
+21 IF $LENGTH(C)'=2
SET C=$EXTRACT(C,1)_0
+22 ;
+23 SET $PIECE(PSUIVA(PSUDIV),U,7)=B_C
End DoDot:1
+24 ;
+25 QUIT
+26 ;
TOTAL ;Add up column totals and place into ^XTMP global
+1 ;
+2 SET PSUDI=0
+3 FOR
SET PSUDI=$ORDER(PSUIVA(PSUDI))
IF PSUDI=""
QUIT
Begin DoDot:1
+4 ;Total TPN's dispensed
SET LDSP=$GET(LDSP)+$PIECE(PSUIVA(PSUDI),U,1)
+5 ;
+6 ;Total TPN's recycled
SET LREC=$GET(LREC)+$PIECE(PSUIVA(PSUDI),U,2)
+7 ;
+8 ;Total TPN's destroyed
SET LDES=$GET(LDES)+$PIECE(PSUIVA(PSUDI),U,3)
+9 ;
+10 ;Total TPN's cancelled
SET CLAN=$GET(CLAN)+$PIECE(PSUIVA(PSUDI),U,4)
+11 ;
+12 ;Total Net TPN's dispensed
SET NDSP=$GET(NDSP)+$PIECE(PSUIVA(PSUDI),U,5)
+13 ;
+14 ;Total of Total cost
SET LTOT=$GET(LTOT)+$PIECE(PSUIVA(PSUDI),U,6)
+15 ;
+16 ;S CNDSP=$G(CNDSP)+$P(PSUIVA(PSUDI),U,7) ;Total of cost/net column
+17 IF $GET(NDSP)
SET CNDSP=$GET(LTOT)/NDSP
Begin DoDot:2
+18 IF CNDSP'["."
SET CNDSP=CNDSP_".00"
QUIT
+19 NEW A,B,C
+20 ;Find 1st position after decimal
SET A=$FIND(CNDSP,".")
+21 ;Extract dollars and decimal
SET B=$EXTRACT(CNDSP,1,(A-1))
+22 ;Extract cents after decimal
SET C=$EXTRACT(CNDSP,A,(A+1))
+23 IF $LENGTH(C)'=2
SET C=$EXTRACT(C,1)_0
+24 SET CNDSP=B_C
End DoDot:2
End DoDot:1
+25 ;
+26 IF '$DATA(LDSP)
SET LDSP=0
+27 IF '$DATA(LREC)
SET LREC=0
+28 IF '$DATA(LDES)
SET LDES=0
+29 IF '$DATA(CLAN)
SET CLAN=0
+30 IF '$DATA(NDSP)
SET NDSP=0
+31 IF '$DATA(LTOT)
SET LTOT="0.00"
+32 IF '$DATA(CNDSP)
SET CNDSP="0.00"
+33 ;
+34 SET ^XTMP(PSUIVSUB,"TPNTOT")=$GET(LDSP)_U_$GET(LREC)_U_$GET(LDES)_U_$GET(CLAN)_U_$GET(NDSP)_U_$GET(LTOT)_U_$GET(CNDSP)
+35 ;
+36 QUIT
+37 ;
REC ;Place contents of arrays into ^XTMP globals
+1 ;
+2 ;TPN RECORDS
MERGE ^XTMP(PSUIVSUB,"TPN",PSUDIV)=PSUIVA(PSUDIV)
+3 ;
+4 QUIT
