PSUCSR2 ;BIR/DAM - PBM CS AMIS SUMMARY;6 APR 2004
;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
;
;Reference to file #40.8 supported by DBIA 2438
;
EN ;Entry point to create AMIS summary report
;Called from ^PSUCSR1
;
N TYP
K CSAM
;
S PSUDV=0
F S PSUDV=$O(^XTMP(PSUCSJB,"RECORDS",PSUDV)) Q:PSUDV="" D
.S PSUA=0
.F S PSUA=$O(^XTMP(PSUCSJB,"RECORDS",PSUDV,PSUA)) Q:PSUA="" D
..S PSUB=0
..F S PSUB=$O(^XTMP(PSUCSJB,"RECORDS",PSUDV,PSUA,PSUB)) Q:PSUB="" D
...S TYP=^XTMP(PSUCSJB,"RECORDS",PSUDV,PSUA,PSUB,0)
...I TYP=2 D
....D DISP
....D TCOST
.Q:'$D(CSAM(PSUDV))
.D AVE
.D TRUNC
;
D TOTAL
D MSG
D MAIL
;
Q
;
DISP ;Calculate orders dispensed
;
S $P(CSAM(PSUDV),U,1)=$P($G(CSAM(PSUDV)),U,1)+1
;
Q
;
TCOST ;Calculate total cost of orders dispensed
;
N QTY,PRC
;
S QTY=^XTMP(PSUCSJB,"RECORDS",PSUDV,PSUA,PSUB,17)
S PRC=^XTMP(PSUCSJB,"RECORDS",PSUDV,PSUA,PSUB,16)
;
S $P(CSAM(PSUDV),U,2)=$P($G(CSAM(PSUDV)),U,2)+(QTY*PRC)
;
Q
;
AVE ;Calculate average cost per order
;
N TCST,DSP
;
S DSP=$P(CSAM(PSUDV),U,1)
S TCST=$P(CSAM(PSUDV),U,2)
;
S $P(CSAM(PSUDV),U,3)=$P($G(CSAM(PSUDV)),U,3)+(TCST/DSP)
;
Q
;
TRUNC ;Truncate pieces with dollar values to 2 decimal places
;
F I=2:1:3 D
.N A,B,C
.;
.I $P(CSAM(PSUDV),U,I)'["." D Q
..S $P(CSAM(PSUDV),U,I)=$P(CSAM(PSUDV),U,I)_".00"
.;
.S A=$F($P(CSAM(PSUDV),U,I),".") ;Find first position after decimal
.;
.S B=$E($P(CSAM(PSUDV),U,I),1,(A-1)) ;Extract dollars and decimal
.;
.S C=$E($P(CSAM(PSUDV),U,I),A,(A+1)) ;Extract cents after decimal
.;
.I $L(C)'=2 S C=$E(C,1)_0
.;
.S $P(CSAM(PSUDV),U,I)=B_C
;
Q
TOTAL ;Add column totals
;
N TDSP,TCST,TAVE
;
S PSUDIV=0
F S PSUDIV=$O(CSAM(PSUDIV)) Q:PSUDIV="" D
.S TDSP=$G(TDSP)+$P(CSAM(PSUDIV),U,1) ;Total orders dispensed
.S TCST=$G(TCST)+$P(CSAM(PSUDIV),U,2) ;Total of total costs
.I $G(TDSP) S TAVE=$G(TCST)/TDSP 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
;
S TOTAL("TOT")=$G(TDSP)_U_$G(TCST)_U_$G(TAVE)
;
Q
;
MSG ;Construct lines for the MailMan message
;
S Y=PSUSDT\1 X ^DD("DD") S PSUDTS=Y ; start date
S Y=PSUEDT\1 X ^DD("DD") S PSUDTE=Y ; end date
;
K AMISC ;Array to hold message lines
;
S AMISC(1)="Controlled AMIS Summary for "_PSUDTS_" through "_PSUDTE_" for "_PSUDIVNM
;
S AMISC(2)="" ;Blank line
;
I '$D(CSAM) D Q
.S AMISC(3)=" "
.S AMISC(4)="No data to report"
.S AMISC(5)=" "
;
S ^XTMP(PSUCSJB,"MAIL",PSUMC)=PSUDIV
;
S AMISC(3)="INPATIENT CONTROLLED SUBSTANCE ORDERS:"
;
S AMISC(4)="" ;Blank line
;
S AMISC(5)=" ORDERS TOTAL AVE COST"
S AMISC(6)="DIVISION DISPENSED COST PER ORDER"
;
S $P(AMISC(7),"-",78)="" ;Separator bar
;
S PSULN=8
;
S PSUDIV=0
F S PSUDIV=$O(CSAM(PSUDIV)) Q:PSUDIV="" D
.S X=PSUDIV,DIC=40.8,DIC(0)="X",D="C" D IX^DIC
.S X=+Y S PSUDIVNM=$$VAL^PSUTL(40.8,X,.01)
.S PSULINE=""
.S $E(PSULINE,1,17)=PSUDIVNM
.S $E(PSULINE,18,35)=$J($P(CSAM(PSUDIV),U,1),18)
.S $E(PSULINE,41,42)="$"
.S $E(PSULINE,43,53)=$J($P(CSAM(PSUDIV),U,2),11)
.S $E(PSULINE,60,61)="$"
.S $E(PSULINE,62,67)=$J($P(CSAM(PSUDIV),U,3),6)
.S AMISC(PSULN)=PSULINE S PSULN=PSULN+1
;
S $P(AMISC(PSULN),"-",78)="" ;Separator bar
S PSULN=PSULN+1
;
S PSULINE=""
S $E(PSULINE,1,17)="Total"
S $E(PSULINE,18,35)=$J($P(TOTAL("TOT"),U,1),18)
S $E(PSULINE,41,42)="$"
S $E(PSULINE,43,53)=$J($P(TOTAL("TOT"),U,2),11)
S $E(PSULINE,60,61)="$"
S $E(PSULINE,62,67)=$J($P(TOTAL("TOT"),U,3),6)
S AMISC(PSULN)=PSULINE S PSULN=PSULN+1
;
F PSULN=PSULN:1:(PSULN+2) S AMISC(PSULN)="" ;Blank lines
Q
;
MAIL ;Mail CS AMIS summary report
;
;Do not send report if option selection includes 1,2,3,4,6
;Instead send the combined AMIS summary report
I $D(^XTMP("PSU_"_PSUJOB,"CBAMIS")) D Q
.M ^XTMP("PSU_"_PSUJOB,"CSCOMBO")=AMISC
.S ^XTMP("PSU_"_PSUJOB,"CSCOMBO",1)=""
.D EN^PSUAMC
;
M XMY=PSUXMYS2
;
S X=PSUSNDR,DIC=40.8,DIC(0)="X",D="C" D IX^DIC
S X=+Y S PSUDIVNM=$$VAL^PSUTL(40.8,X,.01)
;
S XMSUB="V. 4.0 PBMCS "_PSUMON_" "_PSUSNDR_" "_PSUDIVNM
S XMTEXT="AMISC("
M ^XTMP("PSU_"_PSUJOB,"CSAMIS")=AMISC
S XMCHAN=1
D ^XMD
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUCSR2 4583 printed Oct 16, 2024@18:28:23 Page 2
PSUCSR2 ;BIR/DAM - PBM CS AMIS SUMMARY;6 APR 2004
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
+2 ;
+3 ;Reference to file #40.8 supported by DBIA 2438
+4 ;
EN ;Entry point to create AMIS summary report
+1 ;Called from ^PSUCSR1
+2 ;
+3 NEW TYP
+4 KILL CSAM
+5 ;
+6 SET PSUDV=0
+7 FOR
SET PSUDV=$ORDER(^XTMP(PSUCSJB,"RECORDS",PSUDV))
if PSUDV=""
QUIT
Begin DoDot:1
+8 SET PSUA=0
+9 FOR
SET PSUA=$ORDER(^XTMP(PSUCSJB,"RECORDS",PSUDV,PSUA))
if PSUA=""
QUIT
Begin DoDot:2
+10 SET PSUB=0
+11 FOR
SET PSUB=$ORDER(^XTMP(PSUCSJB,"RECORDS",PSUDV,PSUA,PSUB))
if PSUB=""
QUIT
Begin DoDot:3
+12 SET TYP=^XTMP(PSUCSJB,"RECORDS",PSUDV,PSUA,PSUB,0)
+13 IF TYP=2
Begin DoDot:4
+14 DO DISP
+15 DO TCOST
End DoDot:4
End DoDot:3
End DoDot:2
+16 if '$DATA(CSAM(PSUDV))
QUIT
+17 DO AVE
+18 DO TRUNC
End DoDot:1
+19 ;
+20 DO TOTAL
+21 DO MSG
+22 DO MAIL
+23 ;
+24 QUIT
+25 ;
DISP ;Calculate orders dispensed
+1 ;
+2 SET $PIECE(CSAM(PSUDV),U,1)=$PIECE($GET(CSAM(PSUDV)),U,1)+1
+3 ;
+4 QUIT
+5 ;
TCOST ;Calculate total cost of orders dispensed
+1 ;
+2 NEW QTY,PRC
+3 ;
+4 SET QTY=^XTMP(PSUCSJB,"RECORDS",PSUDV,PSUA,PSUB,17)
+5 SET PRC=^XTMP(PSUCSJB,"RECORDS",PSUDV,PSUA,PSUB,16)
+6 ;
+7 SET $PIECE(CSAM(PSUDV),U,2)=$PIECE($GET(CSAM(PSUDV)),U,2)+(QTY*PRC)
+8 ;
+9 QUIT
+10 ;
AVE ;Calculate average cost per order
+1 ;
+2 NEW TCST,DSP
+3 ;
+4 SET DSP=$PIECE(CSAM(PSUDV),U,1)
+5 SET TCST=$PIECE(CSAM(PSUDV),U,2)
+6 ;
+7 SET $PIECE(CSAM(PSUDV),U,3)=$PIECE($GET(CSAM(PSUDV)),U,3)+(TCST/DSP)
+8 ;
+9 QUIT
+10 ;
TRUNC ;Truncate pieces with dollar values to 2 decimal places
+1 ;
+2 FOR I=2:1:3
Begin DoDot:1
+3 NEW A,B,C
+4 ;
+5 IF $PIECE(CSAM(PSUDV),U,I)'["."
Begin DoDot:2
+6 SET $PIECE(CSAM(PSUDV),U,I)=$PIECE(CSAM(PSUDV),U,I)_".00"
End DoDot:2
QUIT
+7 ;
+8 ;Find first position after decimal
SET A=$FIND($PIECE(CSAM(PSUDV),U,I),".")
+9 ;
+10 ;Extract dollars and decimal
SET B=$EXTRACT($PIECE(CSAM(PSUDV),U,I),1,(A-1))
+11 ;
+12 ;Extract cents after decimal
SET C=$EXTRACT($PIECE(CSAM(PSUDV),U,I),A,(A+1))
+13 ;
+14 IF $LENGTH(C)'=2
SET C=$EXTRACT(C,1)_0
+15 ;
+16 SET $PIECE(CSAM(PSUDV),U,I)=B_C
End DoDot:1
+17 ;
+18 QUIT
TOTAL ;Add column totals
+1 ;
+2 NEW TDSP,TCST,TAVE
+3 ;
+4 SET PSUDIV=0
+5 FOR
SET PSUDIV=$ORDER(CSAM(PSUDIV))
if PSUDIV=""
QUIT
Begin DoDot:1
+6 ;Total orders dispensed
SET TDSP=$GET(TDSP)+$PIECE(CSAM(PSUDIV),U,1)
+7 ;Total of total costs
SET TCST=$GET(TCST)+$PIECE(CSAM(PSUDIV),U,2)
+8 IF $GET(TDSP)
SET TAVE=$GET(TCST)/TDSP
Begin DoDot:2
+9 IF TAVE'["."
SET TAVE=TAVE_".00"
QUIT
+10 NEW A,B,C
+11 ;Find 1st position after decimal
SET A=$FIND(TAVE,".")
+12 ;Extract dollars and decimal
SET B=$EXTRACT(TAVE,1,(A-1))
+13 ;Extract cents after decimal
SET C=$EXTRACT(TAVE,A,(A+1))
+14 IF $LENGTH(C)'=2
SET C=$EXTRACT(C,1)_0
+15 SET TAVE=B_C
End DoDot:2
End DoDot:1
+16 ;
+17 SET TOTAL("TOT")=$GET(TDSP)_U_$GET(TCST)_U_$GET(TAVE)
+18 ;
+19 QUIT
+20 ;
MSG ;Construct lines for the MailMan message
+1 ;
+2 ; start date
SET Y=PSUSDT\1
XECUTE ^DD("DD")
SET PSUDTS=Y
+3 ; end date
SET Y=PSUEDT\1
XECUTE ^DD("DD")
SET PSUDTE=Y
+4 ;
+5 ;Array to hold message lines
KILL AMISC
+6 ;
+7 SET AMISC(1)="Controlled AMIS Summary for "_PSUDTS_" through "_PSUDTE_" for "_PSUDIVNM
+8 ;
+9 ;Blank line
SET AMISC(2)=""
+10 ;
+11 IF '$DATA(CSAM)
Begin DoDot:1
+12 SET AMISC(3)=" "
+13 SET AMISC(4)="No data to report"
+14 SET AMISC(5)=" "
End DoDot:1
QUIT
+15 ;
+16 SET ^XTMP(PSUCSJB,"MAIL",PSUMC)=PSUDIV
+17 ;
+18 SET AMISC(3)="INPATIENT CONTROLLED SUBSTANCE ORDERS:"
+19 ;
+20 ;Blank line
SET AMISC(4)=""
+21 ;
+22 SET AMISC(5)=" ORDERS TOTAL AVE COST"
+23 SET AMISC(6)="DIVISION DISPENSED COST PER ORDER"
+24 ;
+25 ;Separator bar
SET $PIECE(AMISC(7),"-",78)=""
+26 ;
+27 SET PSULN=8
+28 ;
+29 SET PSUDIV=0
+30 FOR
SET PSUDIV=$ORDER(CSAM(PSUDIV))
if PSUDIV=""
QUIT
Begin DoDot:1
+31 SET X=PSUDIV
SET DIC=40.8
SET DIC(0)="X"
SET D="C"
DO IX^DIC
+32 SET X=+Y
SET PSUDIVNM=$$VAL^PSUTL(40.8,X,.01)
+33 SET PSULINE=""
+34 SET $EXTRACT(PSULINE,1,17)=PSUDIVNM
+35 SET $EXTRACT(PSULINE,18,35)=$JUSTIFY($PIECE(CSAM(PSUDIV),U,1),18)
+36 SET $EXTRACT(PSULINE,41,42)="$"
+37 SET $EXTRACT(PSULINE,43,53)=$JUSTIFY($PIECE(CSAM(PSUDIV),U,2),11)
+38 SET $EXTRACT(PSULINE,60,61)="$"
+39 SET $EXTRACT(PSULINE,62,67)=$JUSTIFY($PIECE(CSAM(PSUDIV),U,3),6)
+40 SET AMISC(PSULN)=PSULINE
SET PSULN=PSULN+1
End DoDot:1
+41 ;
+42 ;Separator bar
SET $PIECE(AMISC(PSULN),"-",78)=""
+43 SET PSULN=PSULN+1
+44 ;
+45 SET PSULINE=""
+46 SET $EXTRACT(PSULINE,1,17)="Total"
+47 SET $EXTRACT(PSULINE,18,35)=$JUSTIFY($PIECE(TOTAL("TOT"),U,1),18)
+48 SET $EXTRACT(PSULINE,41,42)="$"
+49 SET $EXTRACT(PSULINE,43,53)=$JUSTIFY($PIECE(TOTAL("TOT"),U,2),11)
+50 SET $EXTRACT(PSULINE,60,61)="$"
+51 SET $EXTRACT(PSULINE,62,67)=$JUSTIFY($PIECE(TOTAL("TOT"),U,3),6)
+52 SET AMISC(PSULN)=PSULINE
SET PSULN=PSULN+1
+53 ;
+54 ;Blank lines
FOR PSULN=PSULN:1:(PSULN+2)
SET AMISC(PSULN)=""
+55 QUIT
+56 ;
MAIL ;Mail CS AMIS summary report
+1 ;
+2 ;Do not send report if option selection includes 1,2,3,4,6
+3 ;Instead send the combined AMIS summary report
+4 IF $DATA(^XTMP("PSU_"_PSUJOB,"CBAMIS"))
Begin DoDot:1
+5 MERGE ^XTMP("PSU_"_PSUJOB,"CSCOMBO")=AMISC
+6 SET ^XTMP("PSU_"_PSUJOB,"CSCOMBO",1)=""
+7 DO EN^PSUAMC
End DoDot:1
QUIT
+8 ;
+9 MERGE XMY=PSUXMYS2
+10 ;
+11 SET X=PSUSNDR
SET DIC=40.8
SET DIC(0)="X"
SET D="C"
DO IX^DIC
+12 SET X=+Y
SET PSUDIVNM=$$VAL^PSUTL(40.8,X,.01)
+13 ;
+14 SET XMSUB="V. 4.0 PBMCS "_PSUMON_" "_PSUSNDR_" "_PSUDIVNM
+15 SET XMTEXT="AMISC("
+16 MERGE ^XTMP("PSU_"_PSUJOB,"CSAMIS")=AMISC
+17 SET XMCHAN=1
+18 DO ^XMD
+19 ;
+20 QUIT
