PSUOP8 ;BIR/DAM - Outpatient AMIS Summary Message;04 MAR 2004
;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
;
;Reference to file #59 supported by DBIA 2510
;
EN ;Entry point for MailMan message
;Called from PSUOP0
;
Q:$D(^XTMP("PSU_"_PSUJOB,"PSUFLAG")) ;Quit if Provider extract only
D MSG
D MAIL
Q
;
MSG ;Create the Rx AMIS summary mailman message
;Called from PSUOP0
;
S (PSU30,PSU60,PSU90,PSUNADJ,PSUEQ,PSUTCST,PSUNADC,PSUCFIL)=""
S (PSUNEW,PSUREF,PSUWN,PSUWNCS,PSUML,PSUMLCS,PSUMP,PSULC)=""
S (PSUSTF,PSUFEE,PSULOCS,PSUSTNM)=""
;
S PSUST=$P($G(^XTMP("PSU_"_PSUJOB,"PSUSITE")),U,1) ;Facility #
S PSUSTNM=$P($G(^XTMP("PSU_"_PSUJOB,"PSUSITE")),U,2) ;Facility name
;
D TCOST ;Calculate total cost for all Rx fills
;
S Y=PSUSDT X ^DD("DD") S PSUDTS=Y
S Y=PSUEDT X ^DD("DD") S PSUDTE=Y
S AMIS(1)="Outpatient AMIS Summary for "_PSUDTS_" through "_PSUDTE_" for "_PSUSTNM
;
S AMIS(2)=""
;
S AMIS(3)=" Unadj 30Day Cost/ Cost/"
;
S AMIS(4)=" 30Day 60Day 90Day Total Equiv Total Unadj 30Day"
;
S AMIS(5)="Division Fills Fills Fills Fills Fills Cost Fill Fill"
;
S $P(AMIS(6),"-",132)="" ;Separator bar
;
S PSULN=7
;
S PSUDVN=0
F S PSUDVN=$O(^TMP($J,"FILL",PSUDVN)) Q:PSUDVN="" D
.S X=PSUDVN,DIC=59,DIC(0)="XM" D ^DIC ;Find division name
.S X=+Y,PSUDIVNM=$$VAL^PSUTL(59,X,.01)
.I '$G(PSUDIVNM) S X=PSUDVN,DIC=40.8,DIC(0)="X",D="C" D IX^DIC D
..S X=+Y S PSUDIVNM=$$VAL^PSUTL(40.8,X,.01)
.D VAR
.D UNADCST
.D FILL
.D TOTAL1
.;
.;Construct line with spacing
.S PSULINE=""
.S $E(PSULINE,1,17)=PSUDIVNM
.S $E(PSULINE,18,28)=$J(FILL30,11)
.S $E(PSULINE,29,39)=$J(FILL60,11)
.S $E(PSULINE,40,50)=$J(FILL90,11)
.S $E(PSULINE,51,61)=$J(UNAD,11)
.S $E(PSULINE,62,72)=$J(EQUIV,11)
.S $E(PSULINE,74,75)="$"
.S $E(PSULINE,76,88)=$J(TCOST(PSUDVN),13)
.S $E(PSULINE,90,91)="$"
.S $E(PSULINE,92,102)=$J(UNADC(PSUDVN),11)
.S $E(PSULINE,104,105)="$"
.S $E(PSULINE,106,116)=$J(CFILL(PSUDVN),11)
.;End line
.S AMIS(PSULN)=PSULINE S PSULN=PSULN+1
;
S $P(AMIS(PSULN),"-",132)="" S PSULN=PSULN+1 ;Separator bar
;
;Construct line with spacing
S PSULINE=""
S $E(PSULINE,1,17)="Total"
S $E(PSULINE,18,28)=$J(PSU30,11)
S $E(PSULINE,29,39)=$J(PSU60,11)
S $E(PSULINE,40,50)=$J(PSU90,11)
S $E(PSULINE,51,61)=$J(PSUNADJ,11)
S $E(PSULINE,62,72)=$J(PSUEQ,11)
S $E(PSULINE,74,75)="$"
S $E(PSULINE,76,88)=$J(PSUTCST,13)
S $E(PSULINE,90,91)="$"
S $E(PSULINE,92,102)=$J(PSUNADC,11)
S $E(PSULINE,104,105)="$"
S $E(PSULINE,106,116)=$J(PSUCFIL,11)
;End line construction
;
S AMIS(PSULN)=PSULINE S PSULN=PSULN+1
;
F PSULN=PSULN:1:(PSULN+2) S AMIS(PSULN)="" ;Blank lines
S PSULN=PSULN+1
;
S AMIS(PSULN)="Unadjusted New Ref Win Mail CMOP Local Staff Fee" S PSULN=PSULN+1
;
S AMIS(PSULN)="Division Rx Rx Rx(CS) Rx(CS) Rx Rx(CS) Rx Rx" S PSULN=PSULN+1
;
S $P(AMIS(PSULN),"-",132)="" S PSULN=PSULN+1 ;Separator bar
;
S PSUDVN=0
F S PSUDVN=$O(^TMP($J,"NEW",PSUDVN)) Q:PSUDVN="" D
.S X=PSUDVN,DIC=59,DIC(0)="XM" D ^DIC ;Find division name
.S X=+Y,PSUDIVNM=$$VAL^PSUTL(59,X,.01)
.I '$G(PSUDIVNM) S X=PSUDVN,DIC=40.8,DIC(0)="X",D="C" D IX^DIC D
..S X=+Y S PSUDIVNM=$$VAL^PSUTL(40.8,X,.01)
.D VAR2
.D TOTAL2
.;Construct line with spacing
.S PSULINE=""
.S $E(PSULINE,1,17)=PSUDIVNM
.S $E(PSULINE,18,27)=$J(PSUN,10)
.S $E(PSULINE,28,37)=$J(PSUR,10)
.S $E(PSULINE,38,47)=$J(PSUW,10)
.S $E(PSULINE,48,57)="("_PSUWCS_")"
.S $E(PSULINE,58,67)=$J(PSUM,10)
.S $E(PSULINE,68,77)="("_PSUMCS_")"
.S $E(PSULINE,78,87)=$J(PSUMOP,10)
.S $E(PSULINE,88,97)=$J(PSULOC,10)
.S $E(PSULINE,98,107)="("_PSULCS_")"
.S $E(PSULINE,108,117)=$J(PSUTF,10)
.S $E(PSULINE,118,127)=$J(PSUFE,10)
.;End construction of line
.S AMIS(PSULN)=PSULINE S PSULN=PSULN+1
;
S $P(AMIS(PSULN),"-",132)="" S PSULN=PSULN+1 ;Separator bar
;
;Construct line with spacing
S PSULINE=""
S $E(PSULINE,1,15)="Total"
S $E(PSULINE,18,27)=$J(PSUNEW,10)
S $E(PSULINE,28,37)=$J(PSUREF,10)
S $E(PSULINE,38,47)=$J(PSUWN,10)
S $E(PSULINE,48,57)="("_PSUWNCS_")"
S $E(PSULINE,58,67)=$J(PSUML,10)
S $E(PSULINE,68,77)="("_PSUMLCS_")"
S $E(PSULINE,78,87)=$J(PSUMP,10)
S $E(PSULINE,88,97)=$J(PSULC,10)
S $E(PSULINE,98,107)="("_PSULOCS_")"
S $E(PSULINE,108,117)=$J(PSUSTF,10)
S $E(PSULINE,118,127)=$J(PSUFEE,10)
;End construction of line
S AMIS(PSULN)=PSULINE S PSULN=PSULN+1
;
Q
;
VAR ;Set contents of ^TMP global into VARIABLES
;
S (FILL30,FILL60,FILL90,UNAD,EQUIV)=""
;
S FILL30=^TMP($J,"FILL",PSUDVN,30) ;30 DAY FILLS
;
S FILL60=^TMP($J,"FILL",PSUDVN,60) ;60 DAY FILLS
;
S FILL90=^TMP($J,"FILL",PSUDVN,90) ;90 DAY FILLS
;
S UNAD=^TMP($J,"UNAD",PSUDVN) ;UNADJUSTED TOTAL FILLS
;
S EQUIV=^TMP($J,"EQUIV",PSUDVN) ;30 DAY EQUIV FILLS
;
Q
;
TCOST ;Calculate total cost for prescription fills
;
S PSUTC="",PSUTCOST=""
;
S PSUDIVN=0
F S PSUDIVN=$O(^TMP($J,"COST",PSUDIVN)) Q:PSUDIVN="" D
.S PSURXIEN=0
.F S PSURXIEN=$O(^TMP($J,"COST",PSUDIVN,PSURXIEN)) Q:PSURXIEN="" D
..S PSUTCOST=^TMP($J,"COST",PSUDIVN,PSURXIEN)
..S TCOST(PSUDIVN)=$G(TCOST(PSUDIVN))+PSUTCOST
..I TCOST(PSUDIVN)'["." S TCOST(PSUDIVN)=TCOST(PSUDIVN)_".00" Q
..N A,B,C
..S A=$F(TCOST(PSUDIVN),".") ;Find 1st position after decimal
..S B=$E(TCOST(PSUDIVN),1,(A-1)) ;Extract dollars and decimal
..S C=$E(TCOST(PSUDIVN),A,(A+1)) ;Extract cents after decimal
..I $L(C)'=2 S C=$E(C,1)_0
..S TCOST(PSUDIVN)=B_C
;
Q
;
UNADCST ;Calculate Cost Per Unadjusted Fill
;
N A,B,C
S UNADC(PSUDVN)=TCOST(PSUDVN)/UNAD
;
I UNADC(PSUDVN)'["." S UNADC(PSUDVN)=UNADC(PSUDVN)_".00" Q
;
S A=$F(UNADC(PSUDVN),".") ;Find position of 1st # after decimal
;
S B=$E(UNADC(PSUDVN),1,(A-1)) ;Extract "dollars" up to decimal
;
S C=$E(UNADC(PSUDVN),A,(A+1)) ;Extract "cents" after decimal
;
S UNADC(PSUDVN)=B_C
Q
;
FILL ;Calculate Cost Per 30-day Fill
;
N A,B,C
S CFILL(PSUDVN)=TCOST(PSUDVN)/EQUIV
;
I CFILL(PSUDVN)'["." S CFILL(PSUDVN)=CFILL(PSUDVN)_".00" Q
;
S A=$F(CFILL(PSUDVN),".") ;Find position of 1st # after decimal
;
S B=$E(CFILL(PSUDVN),1,(A-1)) ;Extract "dollars" up to decimal
;
S C=$E(CFILL(PSUDVN),A,(A+1)) ;Extract "cents" after decimal
;
S CFILL(PSUDVN)=B_C
;
Q
;
VAR2 ;Set contents of ^TMP globals into variables
;
S (PSUN,PSUR,PSUW,PSUWCS,PSUM,PSUMCS)=""
S (PSUMOP,PSULOC,PSULCS,PSUTF,PSUFE)=""
;
S PSUN=^TMP($J,"NEW",PSUDVN) ;NEW FILLS
;
S PSUR=^TMP($J,"REF",PSUDVN) ;REFILLS
;
S PSUW=^TMP($J,"WIN",PSUDVN) ;WINDOW FILLS
;
S PSUWCS=^TMP($J,"WINCS",PSUDVN) ;WINDOW CS
;
S PSUM=^TMP($J,"MAIL",PSUDVN) ;MAIL FILLS
;
S PSUMCS=^TMP($J,"MAILCS",PSUDVN) ;MAIL CS
;
S PSUMOP=^TMP($J,"CMOP",PSUDVN) ;CMOP FILLS
;
S PSULOC=^TMP($J,"LOC",PSUDVN) ;LOCAL FILLS
;
S PSULCS=^TMP($J,"LOCS",PSUDVN) ;LOCAL CS
;
S PSUTF=^TMP($J,"STAFF",PSUDVN) ;STAFF FILLS
;
S PSUFE=^TMP($J,"FEE",PSUDVN) ;FEE FILLS
;
Q
;
TOTAL1 ;Add each column to get totals for all divisions
;
;
S PSU30=$G(PSU30)+FILL30 ;Total 30 day fills
;
S PSU60=$G(PSU60)+FILL60 ;Total 60 day fills
;
S PSU90=$G(PSU90)+FILL90 ;Total 90 day fills
;
S PSUNADJ=$G(PSUNADJ)+UNAD ;Total unadjusted fills
;
S PSUEQ=$G(PSUEQ)+EQUIV ;Total 30 day equiv fills
;
S PSUTCST=$G(PSUTCST)+TCOST(PSUDVN) ;Total of Total Cost
;
;S PSUNADC=$G(PSUNADC)+UNADC(PSUDVN) ;Total of Cost/Unadj fill
I $G(PSUNADJ) S PSUNADC=$G(PSUTCST)/PSUNADJ D
.I PSUNADC'["." S PSUNADC=PSUNADC_".00" Q
.N A,B,C
.S A=$F(PSUNADC,".") ;Find 1st position after decimal
.S B=$E(PSUNADC,1,(A-1)) ;Extract dollars and decimal
.S C=$E(PSUNADC,A,(A+1)) ;Extract cents after decimal
.I $L(C)'=2 S C=$E(C,1)_0
.S PSUNADC=B_C
;
;S PSUCFIL=$G(PSUCFIL)+CFILL(PSUDVN) ;Total of Cost/30day fill
I $G(PSUEQ) S PSUCFIL=$G(PSUTCST)/PSUEQ D
.I PSUCFIL'["." S PSUCFIL=PSUCFIL_".00" Q
.N A,B,C
.S A=$F(PSUCFIL,".") ;Find 1st position after decimal
.S B=$E(PSUCFIL,1,(A-1)) ;Extract dollars and decimal
.S C=$E(PSUCFIL,A,(A+1)) ;Extract cents after decimal
.I $L(C)'=2 S C=$E(C,1)_0
.S PSUCFIL=B_C
;
Q
;
TOTAL2 ;Add each column to get totals for all divisions
;
S PSUNEW=$G(PSUNEW)+^TMP($J,"NEW",PSUDVN)
;
S PSUREF=$G(PSUREF)+^TMP($J,"REF",PSUDVN)
;
S PSUWN=$G(PSUWN)+^TMP($J,"WIN",PSUDVN)
;
S PSUWNCS=$G(PSUWNCS)+^TMP($J,"WINCS",PSUDVN)
;
S PSUML=$G(PSUML)+^TMP($J,"MAIL",PSUDVN)
;
S PSUMLCS=$G(PSUMLCS)+^TMP($J,"MAILCS",PSUDVN)
;
S PSUMP=$G(PSUMP)+^TMP($J,"CMOP",PSUDVN)
;
S PSULC=$G(PSULC)+^TMP($J,"LOC",PSUDVN)
;
S PSULOCS=$G(PSULOCS)+^TMP($J,"LOCS",PSUDVN)
;
S PSUSTF=$G(PSUSTF)+^TMP($J,"STAFF",PSUDVN)
;
S PSUFEE=$G(PSUFEE)+^TMP($J,"FEE",PSUDVN)
;
Q
;
MAIL ;Send AMIS summary mailman message
;
;Do not send report if option selection includes 1,2,3,4,6
I $D(^XTMP("PSU_"_PSUJOB,"CBAMIS")) D Q
.M ^XTMP("PSU_"_PSUJOB,"OPCOMBO")=AMIS
.S ^XTMP("PSU_"_PSUJOB,"OPCOMBO",1)="OUTPATIENT:"
;
S XMSUB="V. 4.0 PBMOP "_PSUMON_" "_PSUST_" "_PSUSTNM
S XMTEXT="AMIS("
M ^XTMP("PSU_"_PSUJOB,"OPAMIS")=AMIS
S XMCHAN=1
M XMY=PSUXMYS2
D ^XMD
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUOP8 9812 printed Apr 09, 2024@21:31:26 Page 2
PSUOP8 ;BIR/DAM - Outpatient AMIS Summary Message;04 MAR 2004
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
+2 ;
+3 ;Reference to file #59 supported by DBIA 2510
+4 ;
EN ;Entry point for MailMan message
+1 ;Called from PSUOP0
+2 ;
+3 ;Quit if Provider extract only
if $DATA(^XTMP("PSU_"_PSUJOB,"PSUFLAG"))
QUIT
+4 DO MSG
+5 DO MAIL
+6 QUIT
+7 ;
MSG ;Create the Rx AMIS summary mailman message
+1 ;Called from PSUOP0
+2 ;
+3 SET (PSU30,PSU60,PSU90,PSUNADJ,PSUEQ,PSUTCST,PSUNADC,PSUCFIL)=""
+4 SET (PSUNEW,PSUREF,PSUWN,PSUWNCS,PSUML,PSUMLCS,PSUMP,PSULC)=""
+5 SET (PSUSTF,PSUFEE,PSULOCS,PSUSTNM)=""
+6 ;
+7 ;Facility #
SET PSUST=$PIECE($GET(^XTMP("PSU_"_PSUJOB,"PSUSITE")),U,1)
+8 ;Facility name
SET PSUSTNM=$PIECE($GET(^XTMP("PSU_"_PSUJOB,"PSUSITE")),U,2)
+9 ;
+10 ;Calculate total cost for all Rx fills
DO TCOST
+11 ;
+12 SET Y=PSUSDT
XECUTE ^DD("DD")
SET PSUDTS=Y
+13 SET Y=PSUEDT
XECUTE ^DD("DD")
SET PSUDTE=Y
+14 SET AMIS(1)="Outpatient AMIS Summary for "_PSUDTS_" through "_PSUDTE_" for "_PSUSTNM
+15 ;
+16 SET AMIS(2)=""
+17 ;
+18 SET AMIS(3)=" Unadj 30Day Cost/ Cost/"
+19 ;
+20 SET AMIS(4)=" 30Day 60Day 90Day Total Equiv Total Unadj 30Day"
+21 ;
+22 SET AMIS(5)="Division Fills Fills Fills Fills Fills Cost Fill Fill"
+23 ;
+24 ;Separator bar
SET $PIECE(AMIS(6),"-",132)=""
+25 ;
+26 SET PSULN=7
+27 ;
+28 SET PSUDVN=0
+29 FOR
SET PSUDVN=$ORDER(^TMP($JOB,"FILL",PSUDVN))
if PSUDVN=""
QUIT
Begin DoDot:1
+30 ;Find division name
SET X=PSUDVN
SET DIC=59
SET DIC(0)="XM"
DO ^DIC
+31 SET X=+Y
SET PSUDIVNM=$$VAL^PSUTL(59,X,.01)
+32 IF '$GET(PSUDIVNM)
SET X=PSUDVN
SET DIC=40.8
SET DIC(0)="X"
SET D="C"
DO IX^DIC
Begin DoDot:2
+33 SET X=+Y
SET PSUDIVNM=$$VAL^PSUTL(40.8,X,.01)
End DoDot:2
+34 DO VAR
+35 DO UNADCST
+36 DO FILL
+37 DO TOTAL1
+38 ;
+39 ;Construct line with spacing
+40 SET PSULINE=""
+41 SET $EXTRACT(PSULINE,1,17)=PSUDIVNM
+42 SET $EXTRACT(PSULINE,18,28)=$JUSTIFY(FILL30,11)
+43 SET $EXTRACT(PSULINE,29,39)=$JUSTIFY(FILL60,11)
+44 SET $EXTRACT(PSULINE,40,50)=$JUSTIFY(FILL90,11)
+45 SET $EXTRACT(PSULINE,51,61)=$JUSTIFY(UNAD,11)
+46 SET $EXTRACT(PSULINE,62,72)=$JUSTIFY(EQUIV,11)
+47 SET $EXTRACT(PSULINE,74,75)="$"
+48 SET $EXTRACT(PSULINE,76,88)=$JUSTIFY(TCOST(PSUDVN),13)
+49 SET $EXTRACT(PSULINE,90,91)="$"
+50 SET $EXTRACT(PSULINE,92,102)=$JUSTIFY(UNADC(PSUDVN),11)
+51 SET $EXTRACT(PSULINE,104,105)="$"
+52 SET $EXTRACT(PSULINE,106,116)=$JUSTIFY(CFILL(PSUDVN),11)
+53 ;End line
+54 SET AMIS(PSULN)=PSULINE
SET PSULN=PSULN+1
End DoDot:1
+55 ;
+56 ;Separator bar
SET $PIECE(AMIS(PSULN),"-",132)=""
SET PSULN=PSULN+1
+57 ;
+58 ;Construct line with spacing
+59 SET PSULINE=""
+60 SET $EXTRACT(PSULINE,1,17)="Total"
+61 SET $EXTRACT(PSULINE,18,28)=$JUSTIFY(PSU30,11)
+62 SET $EXTRACT(PSULINE,29,39)=$JUSTIFY(PSU60,11)
+63 SET $EXTRACT(PSULINE,40,50)=$JUSTIFY(PSU90,11)
+64 SET $EXTRACT(PSULINE,51,61)=$JUSTIFY(PSUNADJ,11)
+65 SET $EXTRACT(PSULINE,62,72)=$JUSTIFY(PSUEQ,11)
+66 SET $EXTRACT(PSULINE,74,75)="$"
+67 SET $EXTRACT(PSULINE,76,88)=$JUSTIFY(PSUTCST,13)
+68 SET $EXTRACT(PSULINE,90,91)="$"
+69 SET $EXTRACT(PSULINE,92,102)=$JUSTIFY(PSUNADC,11)
+70 SET $EXTRACT(PSULINE,104,105)="$"
+71 SET $EXTRACT(PSULINE,106,116)=$JUSTIFY(PSUCFIL,11)
+72 ;End line construction
+73 ;
+74 SET AMIS(PSULN)=PSULINE
SET PSULN=PSULN+1
+75 ;
+76 ;Blank lines
FOR PSULN=PSULN:1:(PSULN+2)
SET AMIS(PSULN)=""
+77 SET PSULN=PSULN+1
+78 ;
+79 SET AMIS(PSULN)="Unadjusted New Ref Win Mail CMOP Local Staff Fee"
SET PSULN=PSULN+1
+80 ;
+81 SET AMIS(PSULN)="Division Rx Rx Rx(CS) Rx(CS) Rx Rx(CS) Rx Rx"
SET PSULN=PSULN+1
+82 ;
+83 ;Separator bar
SET $PIECE(AMIS(PSULN),"-",132)=""
SET PSULN=PSULN+1
+84 ;
+85 SET PSUDVN=0
+86 FOR
SET PSUDVN=$ORDER(^TMP($JOB,"NEW",PSUDVN))
if PSUDVN=""
QUIT
Begin DoDot:1
+87 ;Find division name
SET X=PSUDVN
SET DIC=59
SET DIC(0)="XM"
DO ^DIC
+88 SET X=+Y
SET PSUDIVNM=$$VAL^PSUTL(59,X,.01)
+89 IF '$GET(PSUDIVNM)
SET X=PSUDVN
SET DIC=40.8
SET DIC(0)="X"
SET D="C"
DO IX^DIC
Begin DoDot:2
+90 SET X=+Y
SET PSUDIVNM=$$VAL^PSUTL(40.8,X,.01)
End DoDot:2
+91 DO VAR2
+92 DO TOTAL2
+93 ;Construct line with spacing
+94 SET PSULINE=""
+95 SET $EXTRACT(PSULINE,1,17)=PSUDIVNM
+96 SET $EXTRACT(PSULINE,18,27)=$JUSTIFY(PSUN,10)
+97 SET $EXTRACT(PSULINE,28,37)=$JUSTIFY(PSUR,10)
+98 SET $EXTRACT(PSULINE,38,47)=$JUSTIFY(PSUW,10)
+99 SET $EXTRACT(PSULINE,48,57)="("_PSUWCS_")"
+100 SET $EXTRACT(PSULINE,58,67)=$JUSTIFY(PSUM,10)
+101 SET $EXTRACT(PSULINE,68,77)="("_PSUMCS_")"
+102 SET $EXTRACT(PSULINE,78,87)=$JUSTIFY(PSUMOP,10)
+103 SET $EXTRACT(PSULINE,88,97)=$JUSTIFY(PSULOC,10)
+104 SET $EXTRACT(PSULINE,98,107)="("_PSULCS_")"
+105 SET $EXTRACT(PSULINE,108,117)=$JUSTIFY(PSUTF,10)
+106 SET $EXTRACT(PSULINE,118,127)=$JUSTIFY(PSUFE,10)
+107 ;End construction of line
+108 SET AMIS(PSULN)=PSULINE
SET PSULN=PSULN+1
End DoDot:1
+109 ;
+110 ;Separator bar
SET $PIECE(AMIS(PSULN),"-",132)=""
SET PSULN=PSULN+1
+111 ;
+112 ;Construct line with spacing
+113 SET PSULINE=""
+114 SET $EXTRACT(PSULINE,1,15)="Total"
+115 SET $EXTRACT(PSULINE,18,27)=$JUSTIFY(PSUNEW,10)
+116 SET $EXTRACT(PSULINE,28,37)=$JUSTIFY(PSUREF,10)
+117 SET $EXTRACT(PSULINE,38,47)=$JUSTIFY(PSUWN,10)
+118 SET $EXTRACT(PSULINE,48,57)="("_PSUWNCS_")"
+119 SET $EXTRACT(PSULINE,58,67)=$JUSTIFY(PSUML,10)
+120 SET $EXTRACT(PSULINE,68,77)="("_PSUMLCS_")"
+121 SET $EXTRACT(PSULINE,78,87)=$JUSTIFY(PSUMP,10)
+122 SET $EXTRACT(PSULINE,88,97)=$JUSTIFY(PSULC,10)
+123 SET $EXTRACT(PSULINE,98,107)="("_PSULOCS_")"
+124 SET $EXTRACT(PSULINE,108,117)=$JUSTIFY(PSUSTF,10)
+125 SET $EXTRACT(PSULINE,118,127)=$JUSTIFY(PSUFEE,10)
+126 ;End construction of line
+127 SET AMIS(PSULN)=PSULINE
SET PSULN=PSULN+1
+128 ;
+129 QUIT
+130 ;
VAR ;Set contents of ^TMP global into VARIABLES
+1 ;
+2 SET (FILL30,FILL60,FILL90,UNAD,EQUIV)=""
+3 ;
+4 ;30 DAY FILLS
SET FILL30=^TMP($JOB,"FILL",PSUDVN,30)
+5 ;
+6 ;60 DAY FILLS
SET FILL60=^TMP($JOB,"FILL",PSUDVN,60)
+7 ;
+8 ;90 DAY FILLS
SET FILL90=^TMP($JOB,"FILL",PSUDVN,90)
+9 ;
+10 ;UNADJUSTED TOTAL FILLS
SET UNAD=^TMP($JOB,"UNAD",PSUDVN)
+11 ;
+12 ;30 DAY EQUIV FILLS
SET EQUIV=^TMP($JOB,"EQUIV",PSUDVN)
+13 ;
+14 QUIT
+15 ;
TCOST ;Calculate total cost for prescription fills
+1 ;
+2 SET PSUTC=""
SET PSUTCOST=""
+3 ;
+4 SET PSUDIVN=0
+5 FOR
SET PSUDIVN=$ORDER(^TMP($JOB,"COST",PSUDIVN))
if PSUDIVN=""
QUIT
Begin DoDot:1
+6 SET PSURXIEN=0
+7 FOR
SET PSURXIEN=$ORDER(^TMP($JOB,"COST",PSUDIVN,PSURXIEN))
if PSURXIEN=""
QUIT
Begin DoDot:2
+8 SET PSUTCOST=^TMP($JOB,"COST",PSUDIVN,PSURXIEN)
+9 SET TCOST(PSUDIVN)=$GET(TCOST(PSUDIVN))+PSUTCOST
+10 IF TCOST(PSUDIVN)'["."
SET TCOST(PSUDIVN)=TCOST(PSUDIVN)_".00"
QUIT
+11 NEW A,B,C
+12 ;Find 1st position after decimal
SET A=$FIND(TCOST(PSUDIVN),".")
+13 ;Extract dollars and decimal
SET B=$EXTRACT(TCOST(PSUDIVN),1,(A-1))
+14 ;Extract cents after decimal
SET C=$EXTRACT(TCOST(PSUDIVN),A,(A+1))
+15 IF $LENGTH(C)'=2
SET C=$EXTRACT(C,1)_0
+16 SET TCOST(PSUDIVN)=B_C
End DoDot:2
End DoDot:1
+17 ;
+18 QUIT
+19 ;
UNADCST ;Calculate Cost Per Unadjusted Fill
+1 ;
+2 NEW A,B,C
+3 SET UNADC(PSUDVN)=TCOST(PSUDVN)/UNAD
+4 ;
+5 IF UNADC(PSUDVN)'["."
SET UNADC(PSUDVN)=UNADC(PSUDVN)_".00"
QUIT
+6 ;
+7 ;Find position of 1st # after decimal
SET A=$FIND(UNADC(PSUDVN),".")
+8 ;
+9 ;Extract "dollars" up to decimal
SET B=$EXTRACT(UNADC(PSUDVN),1,(A-1))
+10 ;
+11 ;Extract "cents" after decimal
SET C=$EXTRACT(UNADC(PSUDVN),A,(A+1))
+12 ;
+13 SET UNADC(PSUDVN)=B_C
+14 QUIT
+15 ;
FILL ;Calculate Cost Per 30-day Fill
+1 ;
+2 NEW A,B,C
+3 SET CFILL(PSUDVN)=TCOST(PSUDVN)/EQUIV
+4 ;
+5 IF CFILL(PSUDVN)'["."
SET CFILL(PSUDVN)=CFILL(PSUDVN)_".00"
QUIT
+6 ;
+7 ;Find position of 1st # after decimal
SET A=$FIND(CFILL(PSUDVN),".")
+8 ;
+9 ;Extract "dollars" up to decimal
SET B=$EXTRACT(CFILL(PSUDVN),1,(A-1))
+10 ;
+11 ;Extract "cents" after decimal
SET C=$EXTRACT(CFILL(PSUDVN),A,(A+1))
+12 ;
+13 SET CFILL(PSUDVN)=B_C
+14 ;
+15 QUIT
+16 ;
VAR2 ;Set contents of ^TMP globals into variables
+1 ;
+2 SET (PSUN,PSUR,PSUW,PSUWCS,PSUM,PSUMCS)=""
+3 SET (PSUMOP,PSULOC,PSULCS,PSUTF,PSUFE)=""
+4 ;
+5 ;NEW FILLS
SET PSUN=^TMP($JOB,"NEW",PSUDVN)
+6 ;
+7 ;REFILLS
SET PSUR=^TMP($JOB,"REF",PSUDVN)
+8 ;
+9 ;WINDOW FILLS
SET PSUW=^TMP($JOB,"WIN",PSUDVN)
+10 ;
+11 ;WINDOW CS
SET PSUWCS=^TMP($JOB,"WINCS",PSUDVN)
+12 ;
+13 ;MAIL FILLS
SET PSUM=^TMP($JOB,"MAIL",PSUDVN)
+14 ;
+15 ;MAIL CS
SET PSUMCS=^TMP($JOB,"MAILCS",PSUDVN)
+16 ;
+17 ;CMOP FILLS
SET PSUMOP=^TMP($JOB,"CMOP",PSUDVN)
+18 ;
+19 ;LOCAL FILLS
SET PSULOC=^TMP($JOB,"LOC",PSUDVN)
+20 ;
+21 ;LOCAL CS
SET PSULCS=^TMP($JOB,"LOCS",PSUDVN)
+22 ;
+23 ;STAFF FILLS
SET PSUTF=^TMP($JOB,"STAFF",PSUDVN)
+24 ;
+25 ;FEE FILLS
SET PSUFE=^TMP($JOB,"FEE",PSUDVN)
+26 ;
+27 QUIT
+28 ;
TOTAL1 ;Add each column to get totals for all divisions
+1 ;
+2 ;
+3 ;Total 30 day fills
SET PSU30=$GET(PSU30)+FILL30
+4 ;
+5 ;Total 60 day fills
SET PSU60=$GET(PSU60)+FILL60
+6 ;
+7 ;Total 90 day fills
SET PSU90=$GET(PSU90)+FILL90
+8 ;
+9 ;Total unadjusted fills
SET PSUNADJ=$GET(PSUNADJ)+UNAD
+10 ;
+11 ;Total 30 day equiv fills
SET PSUEQ=$GET(PSUEQ)+EQUIV
+12 ;
+13 ;Total of Total Cost
SET PSUTCST=$GET(PSUTCST)+TCOST(PSUDVN)
+14 ;
+15 ;S PSUNADC=$G(PSUNADC)+UNADC(PSUDVN) ;Total of Cost/Unadj fill
+16 IF $GET(PSUNADJ)
SET PSUNADC=$GET(PSUTCST)/PSUNADJ
Begin DoDot:1
+17 IF PSUNADC'["."
SET PSUNADC=PSUNADC_".00"
QUIT
+18 NEW A,B,C
+19 ;Find 1st position after decimal
SET A=$FIND(PSUNADC,".")
+20 ;Extract dollars and decimal
SET B=$EXTRACT(PSUNADC,1,(A-1))
+21 ;Extract cents after decimal
SET C=$EXTRACT(PSUNADC,A,(A+1))
+22 IF $LENGTH(C)'=2
SET C=$EXTRACT(C,1)_0
+23 SET PSUNADC=B_C
End DoDot:1
+24 ;
+25 ;S PSUCFIL=$G(PSUCFIL)+CFILL(PSUDVN) ;Total of Cost/30day fill
+26 IF $GET(PSUEQ)
SET PSUCFIL=$GET(PSUTCST)/PSUEQ
Begin DoDot:1
+27 IF PSUCFIL'["."
SET PSUCFIL=PSUCFIL_".00"
QUIT
+28 NEW A,B,C
+29 ;Find 1st position after decimal
SET A=$FIND(PSUCFIL,".")
+30 ;Extract dollars and decimal
SET B=$EXTRACT(PSUCFIL,1,(A-1))
+31 ;Extract cents after decimal
SET C=$EXTRACT(PSUCFIL,A,(A+1))
+32 IF $LENGTH(C)'=2
SET C=$EXTRACT(C,1)_0
+33 SET PSUCFIL=B_C
End DoDot:1
+34 ;
+35 QUIT
+36 ;
TOTAL2 ;Add each column to get totals for all divisions
+1 ;
+2 SET PSUNEW=$GET(PSUNEW)+^TMP($JOB,"NEW",PSUDVN)
+3 ;
+4 SET PSUREF=$GET(PSUREF)+^TMP($JOB,"REF",PSUDVN)
+5 ;
+6 SET PSUWN=$GET(PSUWN)+^TMP($JOB,"WIN",PSUDVN)
+7 ;
+8 SET PSUWNCS=$GET(PSUWNCS)+^TMP($JOB,"WINCS",PSUDVN)
+9 ;
+10 SET PSUML=$GET(PSUML)+^TMP($JOB,"MAIL",PSUDVN)
+11 ;
+12 SET PSUMLCS=$GET(PSUMLCS)+^TMP($JOB,"MAILCS",PSUDVN)
+13 ;
+14 SET PSUMP=$GET(PSUMP)+^TMP($JOB,"CMOP",PSUDVN)
+15 ;
+16 SET PSULC=$GET(PSULC)+^TMP($JOB,"LOC",PSUDVN)
+17 ;
+18 SET PSULOCS=$GET(PSULOCS)+^TMP($JOB,"LOCS",PSUDVN)
+19 ;
+20 SET PSUSTF=$GET(PSUSTF)+^TMP($JOB,"STAFF",PSUDVN)
+21 ;
+22 SET PSUFEE=$GET(PSUFEE)+^TMP($JOB,"FEE",PSUDVN)
+23 ;
+24 QUIT
+25 ;
MAIL ;Send AMIS summary mailman message
+1 ;
+2 ;Do not send report if option selection includes 1,2,3,4,6
+3 IF $DATA(^XTMP("PSU_"_PSUJOB,"CBAMIS"))
Begin DoDot:1
+4 MERGE ^XTMP("PSU_"_PSUJOB,"OPCOMBO")=AMIS
+5 SET ^XTMP("PSU_"_PSUJOB,"OPCOMBO",1)="OUTPATIENT:"
End DoDot:1
QUIT
+6 ;
+7 SET XMSUB="V. 4.0 PBMOP "_PSUMON_" "_PSUST_" "_PSUSTNM
+8 SET XMTEXT="AMIS("
+9 MERGE ^XTMP("PSU_"_PSUJOB,"OPAMIS")=AMIS
+10 SET XMCHAN=1
+11 MERGE XMY=PSUXMYS2
+12 DO ^XMD
+13 ;
+14 QUIT
