PSUUD6 ;BIR/DAM - UD AMIS Summary Message I;23 MAR 2004
;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
;
;Reference to file #42.6 supported by DBIA 4597
;Reference to file #42.7 supported by DBIA 4598
;Reference to file #40.8 supported by DBIA 2438
;
EN ;Entry point to construct globals for AMIS summary message
;Called from PSUUD3
;
K UDAM ;array to hold tabulated data
K SPEC ;array to hold specialty data
;
S PSUDV=0
F S PSUDV=$O(^XTMP(PSUUDSUB,"DIS",PSUDV)) Q:PSUDV="" D
.D DISP
.D RET
.D TCOST
.D NET
.D AVG
.D TRUNC
.D SPEC
.D DIVT
.D GRAND
;
D TOTAL
;
Q
;
DISP ;Add doses dispensed of all drugs for each division
;
N DSP,A
S DSP=^XTMP(PSUUDSUB,"DISP",PSUDV)
S $P(UDAM(PSUDV),U,1)=DSP
;
I $P(UDAM(PSUDV),U,1)["." D
.S A=$F($P(UDAM(PSUDV),U,1),".") ;Find 1st position after decimal
.S $P(UDAM(PSUDV),U,1)=$E($P(UDAM(PSUDV),U,1),1,(A-2)) ;Truncate
;
Q
;
RET ;Add doses returned of all drugs for each division
;
N RET,A
S RET=^XTMP(PSUUDSUB,"RET",PSUDV)
S $P(UDAM(PSUDV),U,2)=RET
;
I $P(UDAM(PSUDV),U,2)["." D
.S A=$F($P(UDAM(PSUDV),U,2),".") ;Find 1st position after decimal
.S $P(UDAM(PSUDV),U,2)=$E($P(UDAM(PSUDV),U,2),1,(A-2)) ;Truncate
Q
;
NET ;Calculate Net doses dispensed of all drugs
;
S $P(UDAM(PSUDV),U,3)=$P(UDAM(PSUDV),U,1)-$P(UDAM(PSUDV),U,2)
;
Q
;
TCOST ;Find total cost per drug
;
N CST,DP,RT,NT
;
S CST=^XTMP(PSUUDSUB,"CST",PSUDV) ;Price per dispensed unit
;
S $P(UDAM(PSUDV),U,4)=CST
;
Q
;
AVG ;Calculate average cost per dose
;
N TCST,NET
;
S NET=$P(UDAM(PSUDV),U,3) ;Net doses dispensed
;
I $G(NET)'>0 S NET=1
;
S TCST=$P(UDAM(PSUDV),U,4) ;Total cost
;
S $P(UDAM(PSUDV),U,5)=$P($G(UDAM(PSUDV)),U,5)+(TCST/NET)
;
Q
;
TRUNC ;Truncate pieces with dollar values to 2 decimal places
;
F I=4:1:5 D
.N A,B,C
.;
.I $P(UDAM(PSUDV),U,I)'["." D Q
..S $P(UDAM(PSUDV),U,I)=$P(UDAM(PSUDV),U,4)_".00"
.;
.S A=$F($P(UDAM(PSUDV),U,I),".") ;Find 1st position after decimal
.;
.S B=$E($P(UDAM(PSUDV),U,I),1,(A-1)) ;Extract dollars and decimal
.;
.S C=$E($P(UDAM(PSUDV),U,I),A,(A+1)) ;Extract cents after decimal
.;
.I $L(C)'=2 S C=$E(C,1)_0
.;
.S $P(UDAM(PSUDV),U,I)=B_C
;
M ^XTMP(PSUUDSUB,"DOSES",PSUDV)=UDAM(PSUDV)
Q
;
TOTAL ;Add dose totals of all divisions
;
N DTOT,RTOT,NETOT,TCST,ACST
;
S PSUD=0
F S PSUD=$O(UDAM(PSUD)) Q:PSUD="" D
.S DTOT=$G(DTOT)+$P(UDAM(PSUD),U,1) ;Total of doses dispensed
.S RTOT=$G(RTOT)+$P(UDAM(PSUD),U,2) ;Total of returned doses
.S NETOT=$G(NETOT)+$P(UDAM(PSUD),U,3) ;Total of net doses disp
.S TCST=$G(TCST)+$P(UDAM(PSUD),U,4) ;Total of total cost
.;S ACST=$G(ACST)+$P(UDAM(PSUD),U,5) ;Total of average cost
.I $G(NETOT) S ACST=$G(TCST)/$G(NETOT) D
..I ACST'["." S ACST=ACST_".00" Q
..N A,B,C
..S A=$F(ACST,".") ;Find 1st position after decimal
..S B=$E(ACST,1,(A-1)) ;Extract dollars and decimal
..S C=$E(ACST,A,(A+1)) ;Extract cents after decimal
..I $L(C)'=2 S C=$E(C,1)_0
..S ACST=B_C
;
S ^XTMP(PSUUDSUB,"DOSTOT")=DTOT_U_RTOT_U_NETOT_U_TCST_U_ACST
;
Q
;
SPEC ;Find out if a monthly extract is being run
;
N PSUMT,PSUMTH
I $D(PSUMON) D
.S PSUMT=PSUMON_"00"
.I $D(^DGAM(334,"B",PSUMT)) D SPEC1
.;
.S PSUMTH=PSUMT
.I $D(^DGAM(345,"B",PSUMTH)) D SPEC2
;
Q
;
SPEC1 ;Find division names from File (#42.6) records within
;the month of the extract
;
N PSUDNM
;
M SPEC(334,PSUMT)=^DGAM(334,PSUMT) ;set node into array
;
S PSUD1=0
F S PSUD1=$O(SPEC(334,PSUMT,"SE",PSUD1)) Q:PSUD1="" D
.S PSUD2=0
.F S PSUD2=$O(SPEC(334,PSUMT,"SE",PSUD1,"D",PSUD2)) Q:PSUD2="" D
..;find division and match to DIVNM
..S X=PSUD2
..S PSUNM=$$VAL^PSUTL(40.8,X,.01)
..S X=PSUDV,DIC=40.8,DIC(0)="X",D="C" D IX^DIC
..S X=+Y S PSUDNM=$$VAL^PSUTL(40.8,X,.01)
..I PSUNM=PSUDNM D REC1
Q
;
REC1 ;Create a record of specialties and days of patient care for File #42.6
;for each division within the month of the extract
;
N SPC,DAYA,DAYB,SPCE
;
S SPC=$P(SPEC(334,PSUMT,"SE",PSUD1,0),U,1) ;Specialty code
;
S DAYA=$P(SPEC(334,PSUMT,"SE",PSUD1,"D",PSUD2,0),U,12) ;Days of care
;
S DAYB=$P(SPEC(334,PSUMT,"SE",PSUD1,"D",PSUD2,0),U,24) ;Days of care >45
;
;
;Find external form of specialty
S:SPC=334 SPCE="PSYCHIATRY"
S:SPC=335 SPCE="INTERMEDIATE"
S:SPC=336 SPCE="MEDICINE"
S:SPC=337 SPCE="NEUROLOGY"
S:SPC=338 SPCE="REHAB MEDICINE"
S:SPC=339 SPCE="BLIND REHAB"
S:SPC=340 SPCE="SPINAL CORD INJURY"
S:SPC=341 SPCE="SURGERY"
;
S ^XTMP(PSUUDSUB,"SPEC",PSUDV,SPC)=SPCE_U_(DAYA+DAYB) ;Record created
;
Q
;
SPEC2 ;Find division names from File (#42.7) records within
;the month of the extract
;
N PSUDNAM
M SPEC(345,PSUMTH)=^DGAM(345,PSUMTH) ;set node into array
;
S PSUD1=0
F S PSUD1=$O(SPEC(345,PSUMTH,"SE",PSUD1)) Q:PSUD1="" D
.S PSUD2=0
.F S PSUD2=$O(SPEC(345,PSUMTH,"SE",PSUD1,"D",PSUD2)) Q:PSUD2="" D
..;find division and match to DIVNM
..S X=PSUD2
..S PSUNM=$$VAL^PSUTL(40.8,X,.01)
..S X=PSUDV,DIC=40.8,DIC(0)="X",D="C" D IX^DIC
..S X=+Y S PSUDNAM=$$VAL^PSUTL(40.8,X,.01)
..I PSUNM=PSUDNAM D REC2
;
Q
;
REC2 ;Create a record of specialties and days of patient care for File #42.7
;for each division within the month of the extract
;
N SPC,DAY,SPCE
;
S SPC=$P($G(SPEC(345,PSUMTH,"SE",PSUD1,0)),U,1) ;Specialty code
;
S DAY=$P($G(SPEC(345,PSUMTH,"SE",PSUD1,"D",PSUD2,0)),U,16) ;Days of care
;
;Find external form of specialty
S:SPC=345 SPCE="VA NURSING HOME"
;
I $D(SPCE) D
.S ^XTMP(PSUUDSUB,"SPEC",PSUDV,SPC)=SPCE_U_DAY ;Record created
Q
;
DIVT ;Calculate division totals
;
N TOT
S PSUSP=0
F S PSUSP=$O(^XTMP(PSUUDSUB,"SPEC",PSUDV,PSUSP)) Q:PSUSP="" D
.S TOT=$G(TOT)+$P(^XTMP(PSUUDSUB,"SPEC",PSUDV,PSUSP),U,2)
.S ^XTMP(PSUUDSUB,"DIVTOT",PSUDV)=TOT
Q
;
GRAND ;Calculate grand total of all divisions
;
;
S ^XTMP(PSUUDSUB,"GTOT")=$G(^XTMP(PSUUDSUB,"GTOT"))+$G(^XTMP(PSUUDSUB,"DIVTOT",PSUDV))
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUUD6 6143 printed Apr 09, 2024@21:31:11 Page 2
PSUUD6 ;BIR/DAM - UD AMIS Summary Message I;23 MAR 2004
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
+2 ;
+3 ;Reference to file #42.6 supported by DBIA 4597
+4 ;Reference to file #42.7 supported by DBIA 4598
+5 ;Reference to file #40.8 supported by DBIA 2438
+6 ;
EN ;Entry point to construct globals for AMIS summary message
+1 ;Called from PSUUD3
+2 ;
+3 ;array to hold tabulated data
KILL UDAM
+4 ;array to hold specialty data
KILL SPEC
+5 ;
+6 SET PSUDV=0
+7 FOR
SET PSUDV=$ORDER(^XTMP(PSUUDSUB,"DIS",PSUDV))
if PSUDV=""
QUIT
Begin DoDot:1
+8 DO DISP
+9 DO RET
+10 DO TCOST
+11 DO NET
+12 DO AVG
+13 DO TRUNC
+14 DO SPEC
+15 DO DIVT
+16 DO GRAND
End DoDot:1
+17 ;
+18 DO TOTAL
+19 ;
+20 QUIT
+21 ;
DISP ;Add doses dispensed of all drugs for each division
+1 ;
+2 NEW DSP,A
+3 SET DSP=^XTMP(PSUUDSUB,"DISP",PSUDV)
+4 SET $PIECE(UDAM(PSUDV),U,1)=DSP
+5 ;
+6 IF $PIECE(UDAM(PSUDV),U,1)["."
Begin DoDot:1
+7 ;Find 1st position after decimal
SET A=$FIND($PIECE(UDAM(PSUDV),U,1),".")
+8 ;Truncate
SET $PIECE(UDAM(PSUDV),U,1)=$EXTRACT($PIECE(UDAM(PSUDV),U,1),1,(A-2))
End DoDot:1
+9 ;
+10 QUIT
+11 ;
RET ;Add doses returned of all drugs for each division
+1 ;
+2 NEW RET,A
+3 SET RET=^XTMP(PSUUDSUB,"RET",PSUDV)
+4 SET $PIECE(UDAM(PSUDV),U,2)=RET
+5 ;
+6 IF $PIECE(UDAM(PSUDV),U,2)["."
Begin DoDot:1
+7 ;Find 1st position after decimal
SET A=$FIND($PIECE(UDAM(PSUDV),U,2),".")
+8 ;Truncate
SET $PIECE(UDAM(PSUDV),U,2)=$EXTRACT($PIECE(UDAM(PSUDV),U,2),1,(A-2))
End DoDot:1
+9 QUIT
+10 ;
NET ;Calculate Net doses dispensed of all drugs
+1 ;
+2 SET $PIECE(UDAM(PSUDV),U,3)=$PIECE(UDAM(PSUDV),U,1)-$PIECE(UDAM(PSUDV),U,2)
+3 ;
+4 QUIT
+5 ;
TCOST ;Find total cost per drug
+1 ;
+2 NEW CST,DP,RT,NT
+3 ;
+4 ;Price per dispensed unit
SET CST=^XTMP(PSUUDSUB,"CST",PSUDV)
+5 ;
+6 SET $PIECE(UDAM(PSUDV),U,4)=CST
+7 ;
+8 QUIT
+9 ;
AVG ;Calculate average cost per dose
+1 ;
+2 NEW TCST,NET
+3 ;
+4 ;Net doses dispensed
SET NET=$PIECE(UDAM(PSUDV),U,3)
+5 ;
+6 IF $GET(NET)'>0
SET NET=1
+7 ;
+8 ;Total cost
SET TCST=$PIECE(UDAM(PSUDV),U,4)
+9 ;
+10 SET $PIECE(UDAM(PSUDV),U,5)=$PIECE($GET(UDAM(PSUDV)),U,5)+(TCST/NET)
+11 ;
+12 QUIT
+13 ;
TRUNC ;Truncate pieces with dollar values to 2 decimal places
+1 ;
+2 FOR I=4:1:5
Begin DoDot:1
+3 NEW A,B,C
+4 ;
+5 IF $PIECE(UDAM(PSUDV),U,I)'["."
Begin DoDot:2
+6 SET $PIECE(UDAM(PSUDV),U,I)=$PIECE(UDAM(PSUDV),U,4)_".00"
End DoDot:2
QUIT
+7 ;
+8 ;Find 1st position after decimal
SET A=$FIND($PIECE(UDAM(PSUDV),U,I),".")
+9 ;
+10 ;Extract dollars and decimal
SET B=$EXTRACT($PIECE(UDAM(PSUDV),U,I),1,(A-1))
+11 ;
+12 ;Extract cents after decimal
SET C=$EXTRACT($PIECE(UDAM(PSUDV),U,I),A,(A+1))
+13 ;
+14 IF $LENGTH(C)'=2
SET C=$EXTRACT(C,1)_0
+15 ;
+16 SET $PIECE(UDAM(PSUDV),U,I)=B_C
End DoDot:1
+17 ;
+18 MERGE ^XTMP(PSUUDSUB,"DOSES",PSUDV)=UDAM(PSUDV)
+19 QUIT
+20 ;
TOTAL ;Add dose totals of all divisions
+1 ;
+2 NEW DTOT,RTOT,NETOT,TCST,ACST
+3 ;
+4 SET PSUD=0
+5 FOR
SET PSUD=$ORDER(UDAM(PSUD))
if PSUD=""
QUIT
Begin DoDot:1
+6 ;Total of doses dispensed
SET DTOT=$GET(DTOT)+$PIECE(UDAM(PSUD),U,1)
+7 ;Total of returned doses
SET RTOT=$GET(RTOT)+$PIECE(UDAM(PSUD),U,2)
+8 ;Total of net doses disp
SET NETOT=$GET(NETOT)+$PIECE(UDAM(PSUD),U,3)
+9 ;Total of total cost
SET TCST=$GET(TCST)+$PIECE(UDAM(PSUD),U,4)
+10 ;S ACST=$G(ACST)+$P(UDAM(PSUD),U,5) ;Total of average cost
+11 IF $GET(NETOT)
SET ACST=$GET(TCST)/$GET(NETOT)
Begin DoDot:2
+12 IF ACST'["."
SET ACST=ACST_".00"
QUIT
+13 NEW A,B,C
+14 ;Find 1st position after decimal
SET A=$FIND(ACST,".")
+15 ;Extract dollars and decimal
SET B=$EXTRACT(ACST,1,(A-1))
+16 ;Extract cents after decimal
SET C=$EXTRACT(ACST,A,(A+1))
+17 IF $LENGTH(C)'=2
SET C=$EXTRACT(C,1)_0
+18 SET ACST=B_C
End DoDot:2
End DoDot:1
+19 ;
+20 SET ^XTMP(PSUUDSUB,"DOSTOT")=DTOT_U_RTOT_U_NETOT_U_TCST_U_ACST
+21 ;
+22 QUIT
+23 ;
SPEC ;Find out if a monthly extract is being run
+1 ;
+2 NEW PSUMT,PSUMTH
+3 IF $DATA(PSUMON)
Begin DoDot:1
+4 SET PSUMT=PSUMON_"00"
+5 IF $DATA(^DGAM(334,"B",PSUMT))
DO SPEC1
+6 ;
+7 SET PSUMTH=PSUMT
+8 IF $DATA(^DGAM(345,"B",PSUMTH))
DO SPEC2
End DoDot:1
+9 ;
+10 QUIT
+11 ;
SPEC1 ;Find division names from File (#42.6) records within
+1 ;the month of the extract
+2 ;
+3 NEW PSUDNM
+4 ;
+5 ;set node into array
MERGE SPEC(334,PSUMT)=^DGAM(334,PSUMT)
+6 ;
+7 SET PSUD1=0
+8 FOR
SET PSUD1=$ORDER(SPEC(334,PSUMT,"SE",PSUD1))
if PSUD1=""
QUIT
Begin DoDot:1
+9 SET PSUD2=0
+10 FOR
SET PSUD2=$ORDER(SPEC(334,PSUMT,"SE",PSUD1,"D",PSUD2))
if PSUD2=""
QUIT
Begin DoDot:2
+11 ;find division and match to DIVNM
+12 SET X=PSUD2
+13 SET PSUNM=$$VAL^PSUTL(40.8,X,.01)
+14 SET X=PSUDV
SET DIC=40.8
SET DIC(0)="X"
SET D="C"
DO IX^DIC
+15 SET X=+Y
SET PSUDNM=$$VAL^PSUTL(40.8,X,.01)
+16 IF PSUNM=PSUDNM
DO REC1
End DoDot:2
End DoDot:1
+17 QUIT
+18 ;
REC1 ;Create a record of specialties and days of patient care for File #42.6
+1 ;for each division within the month of the extract
+2 ;
+3 NEW SPC,DAYA,DAYB,SPCE
+4 ;
+5 ;Specialty code
SET SPC=$PIECE(SPEC(334,PSUMT,"SE",PSUD1,0),U,1)
+6 ;
+7 ;Days of care
SET DAYA=$PIECE(SPEC(334,PSUMT,"SE",PSUD1,"D",PSUD2,0),U,12)
+8 ;
+9 ;Days of care >45
SET DAYB=$PIECE(SPEC(334,PSUMT,"SE",PSUD1,"D",PSUD2,0),U,24)
+10 ;
+11 ;
+12 ;Find external form of specialty
+13 if SPC=334
SET SPCE="PSYCHIATRY"
+14 if SPC=335
SET SPCE="INTERMEDIATE"
+15 if SPC=336
SET SPCE="MEDICINE"
+16 if SPC=337
SET SPCE="NEUROLOGY"
+17 if SPC=338
SET SPCE="REHAB MEDICINE"
+18 if SPC=339
SET SPCE="BLIND REHAB"
+19 if SPC=340
SET SPCE="SPINAL CORD INJURY"
+20 if SPC=341
SET SPCE="SURGERY"
+21 ;
+22 ;Record created
SET ^XTMP(PSUUDSUB,"SPEC",PSUDV,SPC)=SPCE_U_(DAYA+DAYB)
+23 ;
+24 QUIT
+25 ;
SPEC2 ;Find division names from File (#42.7) records within
+1 ;the month of the extract
+2 ;
+3 NEW PSUDNAM
+4 ;set node into array
MERGE SPEC(345,PSUMTH)=^DGAM(345,PSUMTH)
+5 ;
+6 SET PSUD1=0
+7 FOR
SET PSUD1=$ORDER(SPEC(345,PSUMTH,"SE",PSUD1))
if PSUD1=""
QUIT
Begin DoDot:1
+8 SET PSUD2=0
+9 FOR
SET PSUD2=$ORDER(SPEC(345,PSUMTH,"SE",PSUD1,"D",PSUD2))
if PSUD2=""
QUIT
Begin DoDot:2
+10 ;find division and match to DIVNM
+11 SET X=PSUD2
+12 SET PSUNM=$$VAL^PSUTL(40.8,X,.01)
+13 SET X=PSUDV
SET DIC=40.8
SET DIC(0)="X"
SET D="C"
DO IX^DIC
+14 SET X=+Y
SET PSUDNAM=$$VAL^PSUTL(40.8,X,.01)
+15 IF PSUNM=PSUDNAM
DO REC2
End DoDot:2
End DoDot:1
+16 ;
+17 QUIT
+18 ;
REC2 ;Create a record of specialties and days of patient care for File #42.7
+1 ;for each division within the month of the extract
+2 ;
+3 NEW SPC,DAY,SPCE
+4 ;
+5 ;Specialty code
SET SPC=$PIECE($GET(SPEC(345,PSUMTH,"SE",PSUD1,0)),U,1)
+6 ;
+7 ;Days of care
SET DAY=$PIECE($GET(SPEC(345,PSUMTH,"SE",PSUD1,"D",PSUD2,0)),U,16)
+8 ;
+9 ;Find external form of specialty
+10 if SPC=345
SET SPCE="VA NURSING HOME"
+11 ;
+12 IF $DATA(SPCE)
Begin DoDot:1
+13 ;Record created
SET ^XTMP(PSUUDSUB,"SPEC",PSUDV,SPC)=SPCE_U_DAY
End DoDot:1
+14 QUIT
+15 ;
DIVT ;Calculate division totals
+1 ;
+2 NEW TOT
+3 SET PSUSP=0
+4 FOR
SET PSUSP=$ORDER(^XTMP(PSUUDSUB,"SPEC",PSUDV,PSUSP))
if PSUSP=""
QUIT
Begin DoDot:1
+5 SET TOT=$GET(TOT)+$PIECE(^XTMP(PSUUDSUB,"SPEC",PSUDV,PSUSP),U,2)
+6 SET ^XTMP(PSUUDSUB,"DIVTOT",PSUDV)=TOT
End DoDot:1
+7 QUIT
+8 ;
GRAND ;Calculate grand total of all divisions
+1 ;
+2 ;
+3 SET ^XTMP(PSUUDSUB,"GTOT")=$GET(^XTMP(PSUUDSUB,"GTOT"))+$GET(^XTMP(PSUUDSUB,"DIVTOT",PSUDV))
+4 ;
+5 QUIT
