PSUAR6 ;BIR/DAM - AR/WS AMIS Summary Data;11 March 2004
;;4.0;PHARMACY BENEFITS MANAGEMENT;**6**;MARCH, 2005
;
;This routine gathers AR/WS DOSES AMIS Summary data
;No DBIA's needed
;
EN ;Entry point to gather AMIS data. Called from PSUAR0
K PSUAR ;Arrays to hold temporary data
N TRUNC,TOT,NET
S PSUDV=0
F S PSUDV=$O(^XTMP(PSUARSUB,"RECORDS",PSUDV)) Q:PSUDV="" D
.S PSUCT=0
.F S PSUCT=$O(^XTMP(PSUARSUB,"RECORDS",PSUDV,PSUCT)) Q:PSUCT="" D
..K PSUAMIS
..M PSUAMIS(PSUDV,PSUCT)=^XTMP(PSUARSUB,"RECORDS",PSUDV,PSUCT)
..S PSUCAT=""
..S PSUCAT=$P($G(PSUAMIS(PSUDV,PSUCT)),U,14) ;AMIS Category
..D DSP
..D RET
..D NET
..D TCOST
.D AVE
D TOTAL
D EN^PSUAR7 ;Compose and send MailMan message
Q
DSP ;Calculate AR/WS dispensed data
N DSP,DUNT,DFLD,DBLD
I PSUCAT="03 or 04" D ;Doses Data
.S DSP=$P($G(PSUAMIS(PSUDV,PSUCT)),U,19)
.I DSP="" S DSP=0
.S $P(PSUAR("DSP",PSUDV),U,1)=$P($G(PSUAR("DSP",PSUDV)),U,1)+DSP
;
I PSUCAT="06 or 07" D ;Units Data
.S DUNT=$P($G(PSUAMIS(PSUDV,PSUCT)),U,19)
.S:DUNT="" DUNT=0
.S $P(PSUAR("UNIT",PSUDV),U,1)=$P($G(PSUAR("UNIT",PSUDV)),U,1)+DUNT
;
I PSUCAT=17 D ;Fluids/sets data
.S DFLD=$P($G(PSUAMIS(PSUDV,PSUCT)),U,19)
.S:DFLD="" DFLD=0
.S $P(PSUAR("FLD",PSUDV),U,1)=$P($G(PSUAR("FLD",PSUDV)),U,1)+DFLD
;
I PSUCAT=22 D ;Blood products data
.S DBLD=$P($G(PSUAMIS(PSUDV,PSUCT)),U,19)
.S:DBLD="" DBLD=0
.S $P(PSUAR("BLD",PSUDV),U,1)=$P($G(PSUAR("BLD",PSUDV)),U,1)+DBLD
Q
RET ;Calculate AR/WS returned data
N RET,RUNT,RFLD,RBLD
I PSUCAT="03 or 04" D ;Doses data
.S RET=$P($G(PSUAMIS(PSUDV,PSUCT)),U,20)
.I RET="" S RET=0
.S $P(PSUAR("DSP",PSUDV),U,2)=$P($G(PSUAR("DSP",PSUDV)),U,2)+RET
;
I PSUCAT="06 or 07" D ;Unit data
.S RUNT=$P($G(PSUAMIS(PSUDV,PSUCT)),U,20)
.I RUNT="" S RUNT=0
.S $P(PSUAR("UNIT",PSUDV),U,2)=$P($G(PSUAR("UNIT",PSUDV)),U,2)+RUNT
;
I PSUCAT=17 D ;Fluids/sets data
.S RFLD=$P($G(PSUAMIS(PSUDV,PSUCT)),U,20)
.I RFLD="" S RFLD=0
.S $P(PSUAR("FLD",PSUDV),U,2)=$P($G(PSUAR("FLD",PSUDV)),U,2)+RFLD
;
I PSUCAT=22 D ;Blood products data
.S RBLD=$P($G(PSUAMIS(PSUDV,PSUCT)),U,20)
.I RBLD="" S RBLD=0
.S $P(PSUAR("BLD",PSUDV),U,2)=$P($G(PSUAR("BLD",PSUDV)),U,2)+RBLD
Q
NET ;Calculate Net dispensed data
I PSUCAT="03 or 04" D ;Doses data
.S $P(PSUAR("DSP",PSUDV),U,3)=$P(PSUAR("DSP",PSUDV),U,1)-$P(PSUAR("DSP",PSUDV),U,2)
;
I PSUCAT="06 or 07" D ;Unit data
.S $P(PSUAR("UNIT",PSUDV),U,3)=$P(PSUAR("UNIT",PSUDV),U,1)-$P(PSUAR("UNIT",PSUDV),U,2)
;
I PSUCAT=17 D ;Fluids/sets data
.S $P(PSUAR("FLD",PSUDV),U,3)=$P(PSUAR("FLD",PSUDV),U,1)-$P(PSUAR("FLD",PSUDV),U,2)
;
I PSUCAT=22 D ;Blood products data
.S $P(PSUAR("BLD",PSUDV),U,3)=$P(PSUAR("BLD",PSUDV),U,1)-$P(PSUAR("BLD",PSUDV),U,2)
Q
TCOST ;Calculate total cost
N T1,T2
S PSUCA=0
F S PSUCA=$O(^XTMP("PSUTCST",PSUDV,PSUCA)) Q:PSUCA="" D
.I (PSUCA="03")!(PSUCA="04") D
..S T1=$G(^XTMP("PSUTCST",PSUDV,"03"))
..S T2=$G(^XTMP("PSUTCST",PSUDV,"04"))
..S $P(PSUAR("DSP",PSUDV),U,4)=T1+T2
..K T1,T2
.I (PSUCA="06")!(PSUCA="07") D
..S T1=$G(^XTMP("PSUTCST",PSUDV,"06"))
..S T2=$G(^XTMP("PSUTCST",PSUDV,"07"))
..S $P(PSUAR("UNIT",PSUDV),U,4)=T1+T2
..K T1,T2
.I PSUCA=17 D
..S $P(PSUAR("FLD",PSUDV),U,4)=^XTMP("PSUTCST",PSUDV,PSUCA)
.I PSUCA=22 D
..Q:$P($G(PSUAR("BLD",PSUDV)),U,1)=""
..S $P(PSUAR("BLD",PSUDV),U,4)=^XTMP("PSUTCST",PSUDV,PSUCA)
Q
AVE ;Calculate Average cost per dose
N NET,TOT
S NET=$P($G(PSUAR("DSP",PSUDV)),U,3)
I $G(NET)'>0 S NET=1
S TOT=$P($G(PSUAR("DSP",PSUDV)),U,4)
S $P(PSUAR("DSP",PSUDV),U,5)=TOT/NET D
.S TRUNC=PSUAR("DSP",PSUDV) ;transfer node to variable
.D TRUNC
.S PSUAR("DSP",PSUDV)=TRUNC ;transfer node back to array
.K TRUNC
.K TOT,NET
;
I $D(PSUAR("UNIT",PSUDV)) D
.S NET=$P(PSUAR("UNIT",PSUDV),U,3)
.I $G(NET)'>0 S NET=1
.S TOT=$P($G(PSUAR("UNIT",PSUDV)),U,4)
.S $P(PSUAR("UNIT",PSUDV),U,5)=TOT/NET D
..S TRUNC=PSUAR("UNIT",PSUDV) ;transfer node to variable
..D TRUNC
..S PSUAR("UNIT",PSUDV)=TRUNC ;transfer node back to array
..K TRUNC
..K TOT,NET
I '$D(PSUAR("UNIT",PSUDV)) D
.S PSUAR("UNIT",PSUDV)="0.00"_U_"0.00"_U_"0.00"_U_"0.00"_U_"0.00"
;
I $D(PSUAR("FLD",PSUDV)) D
.S NET=$P($G(PSUAR("FLD",PSUDV)),U,3)
.I $G(NET)'>0 S NET=1
.S TOT=$P($G(PSUAR("FLD",PSUDV)),U,4)
.S $P(PSUAR("FLD",PSUDV),U,5)=TOT/NET D
..S TRUNC=PSUAR("FLD",PSUDV) ;transfer node to variable
..D TRUNC
..S PSUAR("FLD",PSUDV)=TRUNC ;transfer node back to array
..K TRUNC
..K TOT,NET
I '$D(PSUAR("FLD",PSUDV)) D
.S PSUAR("FLD",PSUDV)="0.00"_U_"0.00"_U_"0.00"_U_"0.00"_U_"0.00"
;
I $D(PSUAR("BLD",PSUDV)),$G(PSUDIV) D
.S NET=$P(PSUAR("BLD",PSUDV),U,3)
.I $G(NET)'>0 S NET=1
.S TOT=$P($G(PSUAR("BLD",PSUDV)),U,4)
.S $P(PSUAR("BLD",PSUDV),U,5)=TOT/NET D
..S TRUNC=PSUAR("BLD",PSUDV) ;transfer node to variable
..D TRUNC
..S PSUAR("BLD",PSUDV)=TRUNC ;transfer node back to array
..K TRUNC
..K TOT,NET
I '$D(PSUAR("BLD",PSUDV)) D
.S PSUAR("BLD",PSUDV)="0.00"_U_"0.00"_U_"0.00"_U_"0.00"_U_"0.00"
Q
TRUNC ;Truncate pieces with dollar values to 2 decimal places
;
F I=1:1:5 D
.N A,B,C
.I $P(TRUNC,U,I)'["." D Q
..S $P(TRUNC,U,I)=$P(TRUNC,U,I)_".00"
.S A=$F($P(TRUNC,U,I),".") ;Find first position after decimal
.S B=$E($P(TRUNC,U,I),1,(A-1)) ;Extract dollars and decimal
.S C=$E($P(TRUNC,U,I),A,(A+1)) ;Extract cents after decimal
.I $L(C)'=2 S C=$E(C,1)_0
.S $P(TRUNC,U,I)=B_C
Q
TOTAL ;Calculate column totals for each division
;
I $D(PSUAR("DSP")) D
.N TDSP,TRET,TNET,TCST,TAVE
.S PSUDIV=0 ;Doses data
.F S PSUDIV=$O(PSUAR("DSP",PSUDIV)) Q:PSUDIV="" D
..S TDSP=$G(TDSP)+$P(PSUAR("DSP",PSUDIV),U,1) ;Total dispensed
..S TRET=$G(TRET)+$P(PSUAR("DSP",PSUDIV),U,2) ;Total returned
..S TNET=$G(TNET)+$P(PSUAR("DSP",PSUDIV),U,3) ;Total of Net
..S TCST=$G(TCST)+$P(PSUAR("DSP",PSUDIV),U,4) ;Total of total costs
..I $G(TNET) S TAVE=$G(TCST)/TNET D
...I TAVE'["." S TAVE=TAVE_".00" Q
...N A,B,C
...S A=$F(TAVE,".") ;Find 1st position after decimal
...S B=$E(TAVE,1,(A-1)) ;Extract dollars and decimal
...S C=$E(TAVE,A,(A+1)) ;Extract cents after decimal
...I $L(C)'=2 S C=$E(C,1)_0
...S TAVE=B_C
..I '$D(TAVE) S TAVE="0.00"
.;
.S TOTAL("DSP")=TDSP_U_TRET_U_TNET_U_TCST_U_TAVE D
..S TRUNC=TOTAL("DSP") ;Transfer to variable
..D TRUNC
..S TOTAL("DSP")=TRUNC ;Transfer back to array
..K TRUNC
;
I $D(PSUAR("UNIT")) D
.N TDSP,TRET,TNET,TCST,TAVE
.S PSUDIV=0 ;Unit data
.F S PSUDIV=$O(PSUAR("UNIT",PSUDIV)) Q:PSUDIV="" D
..S TDSP=$G(TDSP)+$P(PSUAR("UNIT",PSUDIV),U,1) ;Total dispensed
..S TRET=$G(TRET)+$P(PSUAR("UNIT",PSUDIV),U,2) ;Total returned
..S TNET=$G(TNET)+$P(PSUAR("UNIT",PSUDIV),U,3) ;Total of Net
..S TCST=$G(TCST)+$P(PSUAR("UNIT",PSUDIV),U,4) ;Total of total costs
..I $G(TNET) S TAVE=$G(TCST)/TNET D
...I TAVE'["." S TAVE=TAVE_".00" Q
...N A,B,C
...S A=$F(TAVE,".") ;Find 1st position after decimal
...S B=$E(TAVE,1,(A-1)) ;Extract dollars and decimal
...S C=$E(TAVE,A,(A+1)) ;Extract cents after decimal
...I $L(C)'=2 S C=$E(C,1)_0
...S TAVE=B_C
..I '$D(TAVE) S TAVE="0.00"
.S TOTAL("UNIT")=TDSP_U_TRET_U_TNET_U_TCST_U_TAVE D
..S TRUNC=TOTAL("UNIT") ;Transfer to variable
..D TRUNC
..S TOTAL("UNIT")=TRUNC ;Transfer back to array
..K TRUNC
;
I $D(PSUAR("FLD")) D
.N TDSP,TRET,TNET,TCST,TAVE
.S PSUDIV=0 ;Fluid/sets data
.F S PSUDIV=$O(PSUAR("FLD",PSUDIV)) Q:PSUDIV="" D
..S TDSP=$G(TDSP)+$P(PSUAR("FLD",PSUDIV),U,1) ;Total dispensed
..S TRET=$G(TRET)+$P(PSUAR("FLD",PSUDIV),U,2) ;Total returned
..S TNET=$G(TNET)+$P(PSUAR("FLD",PSUDIV),U,3) ;Total of Net
..S TCST=$G(TCST)+$P(PSUAR("FLD",PSUDIV),U,4) ;Total of total costs
..I $G(TNET) S TAVE=$G(TCST)/TNET D
...I TAVE'["." S TAVE=TAVE_".00" Q
...N A,B,C
...S A=$F(TAVE,".") ;Find 1st position after decimal
...S B=$E(TAVE,1,(A-1)) ;Extract dollars and decimal
...S C=$E(TAVE,A,(A+1)) ;Extract cents after decimal
...I $L(C)'=2 S C=$E(C,1)_0
...S TAVE=B_C
..I '$D(TAVE) S TAVE="0.00"
.S TOTAL("FLD")=TDSP_U_TRET_U_TNET_U_TCST_U_TAVE D
..S TRUNC=TOTAL("FLD") ;Transfer to variable
..D TRUNC
..S TOTAL("FLD")=TRUNC ;Transfer back to array
..K TRUNC
I '$D(PSUAR("FLD")) D
.S TOTAL("FLD")="0.00"_U_"0.00"_U_"0.00"_U_"0.00"_U_"0.00"
;
;
I $D(PSUAR("BLD")) D
.N TDSP,TRET,TNET,TCST,TAVE
.S PSUDIV=0 ;Blood data
.F S PSUDIV=$O(PSUAR("BLD",PSUDIV)) Q:PSUDIV="" D
..S TDSP=$G(TDSP)+$P(PSUAR("BLD",PSUDIV),U,1) ;Total dispensed
..S TRET=$G(TRET)+$P(PSUAR("BLD",PSUDIV),U,2) ;Total returned
..S TNET=$G(TNET)+$P(PSUAR("BLD",PSUDIV),U,3) ;Total of Net
..S TCST=$G(TCST)+$P(PSUAR("BLD",PSUDIV),U,4) ;Total of total costs
..I $G(TNET) S TAVE=$G(TCST)/TNET D
...I TAVE'["." S TAVE=TAVE_".00" Q
...N A,B,C
...S A=$F(TAVE,".") ;Find 1st position after decimal
...S B=$E(TAVE,1,(A-1)) ;Extract dollars and decimal
...S C=$E(TAVE,A,(A+1)) ;Extract cents after decimal
...I $L(C)'=2 S C=$E(C,1)_0
...S TAVE=B_C
..I '$D(TAVE) S TAVE="0.00"
.S TOTAL("BLD")=TDSP_U_TRET_U_TNET_U_TCST_U_TAVE D
..S TRUNC=TOTAL("BLD") ;Transfer to variable
..D TRUNC
..S TOTAL("BLD")=TRUNC ;Transfer back to array
..K TRUNC
I '$D(PSUAR("BLD")) D
.S TOTAL("BLD")="0.00"_U_"0.00"_U_"0.00"_U_"0.00"_U_"0.00"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUAR6 9786 printed Sep 23, 2025@20:03:05 Page 2
PSUAR6 ;BIR/DAM - AR/WS AMIS Summary Data;11 March 2004
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**6**;MARCH, 2005
+2 ;
+3 ;This routine gathers AR/WS DOSES AMIS Summary data
+4 ;No DBIA's needed
+5 ;
EN ;Entry point to gather AMIS data. Called from PSUAR0
+1 ;Arrays to hold temporary data
KILL PSUAR
+2 NEW TRUNC,TOT,NET
+3 SET PSUDV=0
+4 FOR
SET PSUDV=$ORDER(^XTMP(PSUARSUB,"RECORDS",PSUDV))
if PSUDV=""
QUIT
Begin DoDot:1
+5 SET PSUCT=0
+6 FOR
SET PSUCT=$ORDER(^XTMP(PSUARSUB,"RECORDS",PSUDV,PSUCT))
if PSUCT=""
QUIT
Begin DoDot:2
+7 KILL PSUAMIS
+8 MERGE PSUAMIS(PSUDV,PSUCT)=^XTMP(PSUARSUB,"RECORDS",PSUDV,PSUCT)
+9 SET PSUCAT=""
+10 ;AMIS Category
SET PSUCAT=$PIECE($GET(PSUAMIS(PSUDV,PSUCT)),U,14)
+11 DO DSP
+12 DO RET
+13 DO NET
+14 DO TCOST
End DoDot:2
+15 DO AVE
End DoDot:1
+16 DO TOTAL
+17 ;Compose and send MailMan message
DO EN^PSUAR7
+18 QUIT
DSP ;Calculate AR/WS dispensed data
+1 NEW DSP,DUNT,DFLD,DBLD
+2 ;Doses Data
IF PSUCAT="03 or 04"
Begin DoDot:1
+3 SET DSP=$PIECE($GET(PSUAMIS(PSUDV,PSUCT)),U,19)
+4 IF DSP=""
SET DSP=0
+5 SET $PIECE(PSUAR("DSP",PSUDV),U,1)=$PIECE($GET(PSUAR("DSP",PSUDV)),U,1)+DSP
End DoDot:1
+6 ;
+7 ;Units Data
IF PSUCAT="06 or 07"
Begin DoDot:1
+8 SET DUNT=$PIECE($GET(PSUAMIS(PSUDV,PSUCT)),U,19)
+9 if DUNT=""
SET DUNT=0
+10 SET $PIECE(PSUAR("UNIT",PSUDV),U,1)=$PIECE($GET(PSUAR("UNIT",PSUDV)),U,1)+DUNT
End DoDot:1
+11 ;
+12 ;Fluids/sets data
IF PSUCAT=17
Begin DoDot:1
+13 SET DFLD=$PIECE($GET(PSUAMIS(PSUDV,PSUCT)),U,19)
+14 if DFLD=""
SET DFLD=0
+15 SET $PIECE(PSUAR("FLD",PSUDV),U,1)=$PIECE($GET(PSUAR("FLD",PSUDV)),U,1)+DFLD
End DoDot:1
+16 ;
+17 ;Blood products data
IF PSUCAT=22
Begin DoDot:1
+18 SET DBLD=$PIECE($GET(PSUAMIS(PSUDV,PSUCT)),U,19)
+19 if DBLD=""
SET DBLD=0
+20 SET $PIECE(PSUAR("BLD",PSUDV),U,1)=$PIECE($GET(PSUAR("BLD",PSUDV)),U,1)+DBLD
End DoDot:1
+21 QUIT
RET ;Calculate AR/WS returned data
+1 NEW RET,RUNT,RFLD,RBLD
+2 ;Doses data
IF PSUCAT="03 or 04"
Begin DoDot:1
+3 SET RET=$PIECE($GET(PSUAMIS(PSUDV,PSUCT)),U,20)
+4 IF RET=""
SET RET=0
+5 SET $PIECE(PSUAR("DSP",PSUDV),U,2)=$PIECE($GET(PSUAR("DSP",PSUDV)),U,2)+RET
End DoDot:1
+6 ;
+7 ;Unit data
IF PSUCAT="06 or 07"
Begin DoDot:1
+8 SET RUNT=$PIECE($GET(PSUAMIS(PSUDV,PSUCT)),U,20)
+9 IF RUNT=""
SET RUNT=0
+10 SET $PIECE(PSUAR("UNIT",PSUDV),U,2)=$PIECE($GET(PSUAR("UNIT",PSUDV)),U,2)+RUNT
End DoDot:1
+11 ;
+12 ;Fluids/sets data
IF PSUCAT=17
Begin DoDot:1
+13 SET RFLD=$PIECE($GET(PSUAMIS(PSUDV,PSUCT)),U,20)
+14 IF RFLD=""
SET RFLD=0
+15 SET $PIECE(PSUAR("FLD",PSUDV),U,2)=$PIECE($GET(PSUAR("FLD",PSUDV)),U,2)+RFLD
End DoDot:1
+16 ;
+17 ;Blood products data
IF PSUCAT=22
Begin DoDot:1
+18 SET RBLD=$PIECE($GET(PSUAMIS(PSUDV,PSUCT)),U,20)
+19 IF RBLD=""
SET RBLD=0
+20 SET $PIECE(PSUAR("BLD",PSUDV),U,2)=$PIECE($GET(PSUAR("BLD",PSUDV)),U,2)+RBLD
End DoDot:1
+21 QUIT
NET ;Calculate Net dispensed data
+1 ;Doses data
IF PSUCAT="03 or 04"
Begin DoDot:1
+2 SET $PIECE(PSUAR("DSP",PSUDV),U,3)=$PIECE(PSUAR("DSP",PSUDV),U,1)-$PIECE(PSUAR("DSP",PSUDV),U,2)
End DoDot:1
+3 ;
+4 ;Unit data
IF PSUCAT="06 or 07"
Begin DoDot:1
+5 SET $PIECE(PSUAR("UNIT",PSUDV),U,3)=$PIECE(PSUAR("UNIT",PSUDV),U,1)-$PIECE(PSUAR("UNIT",PSUDV),U,2)
End DoDot:1
+6 ;
+7 ;Fluids/sets data
IF PSUCAT=17
Begin DoDot:1
+8 SET $PIECE(PSUAR("FLD",PSUDV),U,3)=$PIECE(PSUAR("FLD",PSUDV),U,1)-$PIECE(PSUAR("FLD",PSUDV),U,2)
End DoDot:1
+9 ;
+10 ;Blood products data
IF PSUCAT=22
Begin DoDot:1
+11 SET $PIECE(PSUAR("BLD",PSUDV),U,3)=$PIECE(PSUAR("BLD",PSUDV),U,1)-$PIECE(PSUAR("BLD",PSUDV),U,2)
End DoDot:1
+12 QUIT
TCOST ;Calculate total cost
+1 NEW T1,T2
+2 SET PSUCA=0
+3 FOR
SET PSUCA=$ORDER(^XTMP("PSUTCST",PSUDV,PSUCA))
if PSUCA=""
QUIT
Begin DoDot:1
+4 IF (PSUCA="03")!(PSUCA="04")
Begin DoDot:2
+5 SET T1=$GET(^XTMP("PSUTCST",PSUDV,"03"))
+6 SET T2=$GET(^XTMP("PSUTCST",PSUDV,"04"))
+7 SET $PIECE(PSUAR("DSP",PSUDV),U,4)=T1+T2
+8 KILL T1,T2
End DoDot:2
+9 IF (PSUCA="06")!(PSUCA="07")
Begin DoDot:2
+10 SET T1=$GET(^XTMP("PSUTCST",PSUDV,"06"))
+11 SET T2=$GET(^XTMP("PSUTCST",PSUDV,"07"))
+12 SET $PIECE(PSUAR("UNIT",PSUDV),U,4)=T1+T2
+13 KILL T1,T2
End DoDot:2
+14 IF PSUCA=17
Begin DoDot:2
+15 SET $PIECE(PSUAR("FLD",PSUDV),U,4)=^XTMP("PSUTCST",PSUDV,PSUCA)
End DoDot:2
+16 IF PSUCA=22
Begin DoDot:2
+17 if $PIECE($GET(PSUAR("BLD",PSUDV)),U,1)=""
QUIT
+18 SET $PIECE(PSUAR("BLD",PSUDV),U,4)=^XTMP("PSUTCST",PSUDV,PSUCA)
End DoDot:2
End DoDot:1
+19 QUIT
AVE ;Calculate Average cost per dose
+1 NEW NET,TOT
+2 SET NET=$PIECE($GET(PSUAR("DSP",PSUDV)),U,3)
+3 IF $GET(NET)'>0
SET NET=1
+4 SET TOT=$PIECE($GET(PSUAR("DSP",PSUDV)),U,4)
+5 SET $PIECE(PSUAR("DSP",PSUDV),U,5)=TOT/NET
Begin DoDot:1
+6 ;transfer node to variable
SET TRUNC=PSUAR("DSP",PSUDV)
+7 DO TRUNC
+8 ;transfer node back to array
SET PSUAR("DSP",PSUDV)=TRUNC
+9 KILL TRUNC
+10 KILL TOT,NET
End DoDot:1
+11 ;
+12 IF $DATA(PSUAR("UNIT",PSUDV))
Begin DoDot:1
+13 SET NET=$PIECE(PSUAR("UNIT",PSUDV),U,3)
+14 IF $GET(NET)'>0
SET NET=1
+15 SET TOT=$PIECE($GET(PSUAR("UNIT",PSUDV)),U,4)
+16 SET $PIECE(PSUAR("UNIT",PSUDV),U,5)=TOT/NET
Begin DoDot:2
+17 ;transfer node to variable
SET TRUNC=PSUAR("UNIT",PSUDV)
+18 DO TRUNC
+19 ;transfer node back to array
SET PSUAR("UNIT",PSUDV)=TRUNC
+20 KILL TRUNC
+21 KILL TOT,NET
End DoDot:2
End DoDot:1
+22 IF '$DATA(PSUAR("UNIT",PSUDV))
Begin DoDot:1
+23 SET PSUAR("UNIT",PSUDV)="0.00"_U_"0.00"_U_"0.00"_U_"0.00"_U_"0.00"
End DoDot:1
+24 ;
+25 IF $DATA(PSUAR("FLD",PSUDV))
Begin DoDot:1
+26 SET NET=$PIECE($GET(PSUAR("FLD",PSUDV)),U,3)
+27 IF $GET(NET)'>0
SET NET=1
+28 SET TOT=$PIECE($GET(PSUAR("FLD",PSUDV)),U,4)
+29 SET $PIECE(PSUAR("FLD",PSUDV),U,5)=TOT/NET
Begin DoDot:2
+30 ;transfer node to variable
SET TRUNC=PSUAR("FLD",PSUDV)
+31 DO TRUNC
+32 ;transfer node back to array
SET PSUAR("FLD",PSUDV)=TRUNC
+33 KILL TRUNC
+34 KILL TOT,NET
End DoDot:2
End DoDot:1
+35 IF '$DATA(PSUAR("FLD",PSUDV))
Begin DoDot:1
+36 SET PSUAR("FLD",PSUDV)="0.00"_U_"0.00"_U_"0.00"_U_"0.00"_U_"0.00"
End DoDot:1
+37 ;
+38 IF $DATA(PSUAR("BLD",PSUDV))
IF $GET(PSUDIV)
Begin DoDot:1
+39 SET NET=$PIECE(PSUAR("BLD",PSUDV),U,3)
+40 IF $GET(NET)'>0
SET NET=1
+41 SET TOT=$PIECE($GET(PSUAR("BLD",PSUDV)),U,4)
+42 SET $PIECE(PSUAR("BLD",PSUDV),U,5)=TOT/NET
Begin DoDot:2
+43 ;transfer node to variable
SET TRUNC=PSUAR("BLD",PSUDV)
+44 DO TRUNC
+45 ;transfer node back to array
SET PSUAR("BLD",PSUDV)=TRUNC
+46 KILL TRUNC
+47 KILL TOT,NET
End DoDot:2
End DoDot:1
+48 IF '$DATA(PSUAR("BLD",PSUDV))
Begin DoDot:1
+49 SET PSUAR("BLD",PSUDV)="0.00"_U_"0.00"_U_"0.00"_U_"0.00"_U_"0.00"
End DoDot:1
+50 QUIT
TRUNC ;Truncate pieces with dollar values to 2 decimal places
+1 ;
+2 FOR I=1:1:5
Begin DoDot:1
+3 NEW A,B,C
+4 IF $PIECE(TRUNC,U,I)'["."
Begin DoDot:2
+5 SET $PIECE(TRUNC,U,I)=$PIECE(TRUNC,U,I)_".00"
End DoDot:2
QUIT
+6 ;Find first position after decimal
SET A=$FIND($PIECE(TRUNC,U,I),".")
+7 ;Extract dollars and decimal
SET B=$EXTRACT($PIECE(TRUNC,U,I),1,(A-1))
+8 ;Extract cents after decimal
SET C=$EXTRACT($PIECE(TRUNC,U,I),A,(A+1))
+9 IF $LENGTH(C)'=2
SET C=$EXTRACT(C,1)_0
+10 SET $PIECE(TRUNC,U,I)=B_C
End DoDot:1
+11 QUIT
TOTAL ;Calculate column totals for each division
+1 ;
+2 IF $DATA(PSUAR("DSP"))
Begin DoDot:1
+3 NEW TDSP,TRET,TNET,TCST,TAVE
+4 ;Doses data
SET PSUDIV=0
+5 FOR
SET PSUDIV=$ORDER(PSUAR("DSP",PSUDIV))
if PSUDIV=""
QUIT
Begin DoDot:2
+6 ;Total dispensed
SET TDSP=$GET(TDSP)+$PIECE(PSUAR("DSP",PSUDIV),U,1)
+7 ;Total returned
SET TRET=$GET(TRET)+$PIECE(PSUAR("DSP",PSUDIV),U,2)
+8 ;Total of Net
SET TNET=$GET(TNET)+$PIECE(PSUAR("DSP",PSUDIV),U,3)
+9 ;Total of total costs
SET TCST=$GET(TCST)+$PIECE(PSUAR("DSP",PSUDIV),U,4)
+10 IF $GET(TNET)
SET TAVE=$GET(TCST)/TNET
Begin DoDot:3
+11 IF TAVE'["."
SET TAVE=TAVE_".00"
QUIT
+12 NEW A,B,C
+13 ;Find 1st position after decimal
SET A=$FIND(TAVE,".")
+14 ;Extract dollars and decimal
SET B=$EXTRACT(TAVE,1,(A-1))
+15 ;Extract cents after decimal
SET C=$EXTRACT(TAVE,A,(A+1))
+16 IF $LENGTH(C)'=2
SET C=$EXTRACT(C,1)_0
+17 SET TAVE=B_C
End DoDot:3
+18 IF '$DATA(TAVE)
SET TAVE="0.00"
End DoDot:2
+19 ;
+20 SET TOTAL("DSP")=TDSP_U_TRET_U_TNET_U_TCST_U_TAVE
Begin DoDot:2
+21 ;Transfer to variable
SET TRUNC=TOTAL("DSP")
+22 DO TRUNC
+23 ;Transfer back to array
SET TOTAL("DSP")=TRUNC
+24 KILL TRUNC
End DoDot:2
End DoDot:1
+25 ;
+26 IF $DATA(PSUAR("UNIT"))
Begin DoDot:1
+27 NEW TDSP,TRET,TNET,TCST,TAVE
+28 ;Unit data
SET PSUDIV=0
+29 FOR
SET PSUDIV=$ORDER(PSUAR("UNIT",PSUDIV))
if PSUDIV=""
QUIT
Begin DoDot:2
+30 ;Total dispensed
SET TDSP=$GET(TDSP)+$PIECE(PSUAR("UNIT",PSUDIV),U,1)
+31 ;Total returned
SET TRET=$GET(TRET)+$PIECE(PSUAR("UNIT",PSUDIV),U,2)
+32 ;Total of Net
SET TNET=$GET(TNET)+$PIECE(PSUAR("UNIT",PSUDIV),U,3)
+33 ;Total of total costs
SET TCST=$GET(TCST)+$PIECE(PSUAR("UNIT",PSUDIV),U,4)
+34 IF $GET(TNET)
SET TAVE=$GET(TCST)/TNET
Begin DoDot:3
+35 IF TAVE'["."
SET TAVE=TAVE_".00"
QUIT
+36 NEW A,B,C
+37 ;Find 1st position after decimal
SET A=$FIND(TAVE,".")
+38 ;Extract dollars and decimal
SET B=$EXTRACT(TAVE,1,(A-1))
+39 ;Extract cents after decimal
SET C=$EXTRACT(TAVE,A,(A+1))
+40 IF $LENGTH(C)'=2
SET C=$EXTRACT(C,1)_0
+41 SET TAVE=B_C
End DoDot:3
+42 IF '$DATA(TAVE)
SET TAVE="0.00"
End DoDot:2
+43 SET TOTAL("UNIT")=TDSP_U_TRET_U_TNET_U_TCST_U_TAVE
Begin DoDot:2
+44 ;Transfer to variable
SET TRUNC=TOTAL("UNIT")
+45 DO TRUNC
+46 ;Transfer back to array
SET TOTAL("UNIT")=TRUNC
+47 KILL TRUNC
End DoDot:2
End DoDot:1
+48 ;
+49 IF $DATA(PSUAR("FLD"))
Begin DoDot:1
+50 NEW TDSP,TRET,TNET,TCST,TAVE
+51 ;Fluid/sets data
SET PSUDIV=0
+52 FOR
SET PSUDIV=$ORDER(PSUAR("FLD",PSUDIV))
if PSUDIV=""
QUIT
Begin DoDot:2
+53 ;Total dispensed
SET TDSP=$GET(TDSP)+$PIECE(PSUAR("FLD",PSUDIV),U,1)
+54 ;Total returned
SET TRET=$GET(TRET)+$PIECE(PSUAR("FLD",PSUDIV),U,2)
+55 ;Total of Net
SET TNET=$GET(TNET)+$PIECE(PSUAR("FLD",PSUDIV),U,3)
+56 ;Total of total costs
SET TCST=$GET(TCST)+$PIECE(PSUAR("FLD",PSUDIV),U,4)
+57 IF $GET(TNET)
SET TAVE=$GET(TCST)/TNET
Begin DoDot:3
+58 IF TAVE'["."
SET TAVE=TAVE_".00"
QUIT
+59 NEW A,B,C
+60 ;Find 1st position after decimal
SET A=$FIND(TAVE,".")
+61 ;Extract dollars and decimal
SET B=$EXTRACT(TAVE,1,(A-1))
+62 ;Extract cents after decimal
SET C=$EXTRACT(TAVE,A,(A+1))
+63 IF $LENGTH(C)'=2
SET C=$EXTRACT(C,1)_0
+64 SET TAVE=B_C
End DoDot:3
+65 IF '$DATA(TAVE)
SET TAVE="0.00"
End DoDot:2
+66 SET TOTAL("FLD")=TDSP_U_TRET_U_TNET_U_TCST_U_TAVE
Begin DoDot:2
+67 ;Transfer to variable
SET TRUNC=TOTAL("FLD")
+68 DO TRUNC
+69 ;Transfer back to array
SET TOTAL("FLD")=TRUNC
+70 KILL TRUNC
End DoDot:2
End DoDot:1
+71 IF '$DATA(PSUAR("FLD"))
Begin DoDot:1
+72 SET TOTAL("FLD")="0.00"_U_"0.00"_U_"0.00"_U_"0.00"_U_"0.00"
End DoDot:1
+73 ;
+74 ;
+75 IF $DATA(PSUAR("BLD"))
Begin DoDot:1
+76 NEW TDSP,TRET,TNET,TCST,TAVE
+77 ;Blood data
SET PSUDIV=0
+78 FOR
SET PSUDIV=$ORDER(PSUAR("BLD",PSUDIV))
if PSUDIV=""
QUIT
Begin DoDot:2
+79 ;Total dispensed
SET TDSP=$GET(TDSP)+$PIECE(PSUAR("BLD",PSUDIV),U,1)
+80 ;Total returned
SET TRET=$GET(TRET)+$PIECE(PSUAR("BLD",PSUDIV),U,2)
+81 ;Total of Net
SET TNET=$GET(TNET)+$PIECE(PSUAR("BLD",PSUDIV),U,3)
+82 ;Total of total costs
SET TCST=$GET(TCST)+$PIECE(PSUAR("BLD",PSUDIV),U,4)
+83 IF $GET(TNET)
SET TAVE=$GET(TCST)/TNET
Begin DoDot:3
+84 IF TAVE'["."
SET TAVE=TAVE_".00"
QUIT
+85 NEW A,B,C
+86 ;Find 1st position after decimal
SET A=$FIND(TAVE,".")
+87 ;Extract dollars and decimal
SET B=$EXTRACT(TAVE,1,(A-1))
+88 ;Extract cents after decimal
SET C=$EXTRACT(TAVE,A,(A+1))
+89 IF $LENGTH(C)'=2
SET C=$EXTRACT(C,1)_0
+90 SET TAVE=B_C
End DoDot:3
+91 IF '$DATA(TAVE)
SET TAVE="0.00"
End DoDot:2
+92 SET TOTAL("BLD")=TDSP_U_TRET_U_TNET_U_TCST_U_TAVE
Begin DoDot:2
+93 ;Transfer to variable
SET TRUNC=TOTAL("BLD")
+94 DO TRUNC
+95 ;Transfer back to array
SET TOTAL("BLD")=TRUNC
+96 KILL TRUNC
End DoDot:2
End DoDot:1
+97 IF '$DATA(PSUAR("BLD"))
Begin DoDot:1
+98 SET TOTAL("BLD")="0.00"_U_"0.00"_U_"0.00"_U_"0.00"_U_"0.00"
End DoDot:1
+99 QUIT
