- PSUV7 ;BIR/DAM - IV PB AMIS Summary Data ;11 March 2004
- ;;4.0;PHARMACY BENEFITS MANAGEMENT;**4,22**;MARCH, 2005;Build 2
- ;
- ;This routine gathers IV Piggyback 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,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=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,5) ;Parent record
- .;
- .S PSUTYP=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,6) ;IV TYPE
- .;
- .I PSUTYP="P" S PSUOR=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,4)_"^"_$P($G(PSUAMIS(PSUDIV,PSUCT)),U,8) ;IV order #^Patient SSN
- .;
- .D LVPDSP
- .D LVPREC
- .D LVPDES
- .D LVPCAN
- .D LVPNET
- .D LVPTOT
- .D CNET
- .D REC
- D TOTAL
- ;
- Q
- ;
- LVPDSP ;Gather PB Dispensed data
- ;
- I PSUTYP="P",PSUP="P" D ;PBs 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 PB Recycled data
- ;
- I PSUTYP="P",PSUP="P" D ;PB'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 PB Destroyed data
- ;
- I PSUTYP="P",PSUP="P" D ;PB'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 PB Cancelled data
- ;
- I PSUTYP="P",PSUP="P" D ;PB'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 PB's Dispensed
- ;
- I PSUTYP="P",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)_"^"_$P(PSUAMIS(PSUDIV,PSUCTA),U,8)
- .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 PB'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 PB's dispensed
- .;
- .S LREC=$G(LREC)+$P(PSUIVA(PSUDI),U,2) ;Total PB's recycled
- .;
- .S LDES=$G(LDES)+$P(PSUIVA(PSUDI),U,3) ;Total PB's destroyed
- .;
- .S CLAN=$G(CLAN)+$P(PSUIVA(PSUDI),U,4) ;Total PB's cancelled
- .;
- .S NDSP=$G(NDSP)+$P(PSUIVA(PSUDI),U,5) ;Total Net PB's dispensed
- .;
- .S LTOT=$G(LTOT)+$P(PSUIVA(PSUDI),U,6) ;Total of Total cost
- .;
- .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,"PBTOT")=LDSP_U_LREC_U_LDES_U_CLAN_U_NDSP_U_LTOT_U_CNDSP
- ;
- Q
- ;
- REC ;Place contents of arrays into ^XTMP globals
- ;
- M ^XTMP(PSUIVSUB,"PB",PSUDIV)=PSUIVA(PSUDIV) ;PB RECORDS
- ;
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUV7 4925 printed Jan 18, 2025@03:29:34 Page 2
- PSUV7 ;BIR/DAM - IV PB AMIS Summary Data ;11 March 2004
- +1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**4,22**;MARCH, 2005;Build 2
- +2 ;
- +3 ;This routine gathers IV Piggyback 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 SET (PSUDIV,PSUCT)=0
- +7 FOR
- SET PSUDIV=$ORDER(^XTMP(PSUIVSUB,"RECORDS",PSUDIV))
- if PSUDIV=""
- QUIT
- DO EN1
- +8 QUIT
- +9 ;
- 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 ;Parent record
- SET PSUP=$PIECE($GET(PSUAMIS(PSUDIV,PSUCT)),U,5)
- +9 ;
- +10 ;IV TYPE
- SET PSUTYP=$PIECE($GET(PSUAMIS(PSUDIV,PSUCT)),U,6)
- +11 ;
- +12 ;IV order #^Patient SSN
- IF PSUTYP="P"
- SET PSUOR=$PIECE($GET(PSUAMIS(PSUDIV,PSUCT)),U,4)_"^"_$PIECE($GET(PSUAMIS(PSUDIV,PSUCT)),U,8)
- +13 ;
- +14 DO LVPDSP
- +15 DO LVPREC
- +16 DO LVPDES
- +17 DO LVPCAN
- +18 DO LVPNET
- +19 DO LVPTOT
- +20 DO CNET
- +21 DO REC
- End DoDot:1
- +22 DO TOTAL
- +23 ;
- +24 QUIT
- +25 ;
- LVPDSP ;Gather PB Dispensed data
- +1 ;
- +2 ;PBs Dispensed
- IF PSUTYP="P"
- 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 PB Recycled data
- +1 ;
- +2 ;PB's recycled
- IF PSUTYP="P"
- 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 PB Destroyed data
- +1 ;
- +2 ;PB's destroyed
- IF PSUTYP="P"
- 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 PB Cancelled data
- +1 ;
- +2 ;PB's cancelled
- IF PSUTYP="P"
- 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 PB's Dispensed
- +1 ;
- +2 IF PSUTYP="P"
- IF PSUP="P"
- Begin DoDot:1
- +3 NEW NET
- +4 SET NET=$PIECE($GET(PSUAMIS(PSUDIV,PSUCT)),U,11)
- +5 SET $PIECE(PSUIVA(PSUDIV),U,5)=$PIECE($GET(PSUIVA(PSUDIV)),U,5)+NET
- End DoDot:1
- +6 QUIT
- +7 ;
- 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)_"^"_$PIECE(PSUAMIS(PSUDIV,PSUCTA),U,8)
- +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 PB'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 PB's dispensed
- SET LDSP=$GET(LDSP)+$PIECE(PSUIVA(PSUDI),U,1)
- +5 ;
- +6 ;Total PB's recycled
- SET LREC=$GET(LREC)+$PIECE(PSUIVA(PSUDI),U,2)
- +7 ;
- +8 ;Total PB's destroyed
- SET LDES=$GET(LDES)+$PIECE(PSUIVA(PSUDI),U,3)
- +9 ;
- +10 ;Total PB's cancelled
- SET CLAN=$GET(CLAN)+$PIECE(PSUIVA(PSUDI),U,4)
- +11 ;
- +12 ;Total Net PB'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 IF $GET(NDSP)
- SET CNDSP=$GET(LTOT)/NDSP
- Begin DoDot:2
- +17 IF CNDSP'["."
- SET CNDSP=CNDSP_".00"
- QUIT
- +18 NEW A,B,C
- +19 ;Find 1st position after decimal
- SET A=$FIND(CNDSP,".")
- +20 ;Extract dollars and decimal
- SET B=$EXTRACT(CNDSP,1,(A-1))
- +21 ;Extract cents after decimal
- SET C=$EXTRACT(CNDSP,A,(A+1))
- +22 IF $LENGTH(C)'=2
- SET C=$EXTRACT(C,1)_0
- +23 SET CNDSP=B_C
- End DoDot:2
- End DoDot:1
- +24 ;
- +25 IF '$DATA(LDSP)
- SET LDSP=0
- +26 IF '$DATA(LREC)
- SET LREC=0
- +27 IF '$DATA(LDES)
- SET LDES=0
- +28 IF '$DATA(CLAN)
- SET CLAN=0
- +29 IF '$DATA(NDSP)
- SET NDSP=0
- +30 IF '$DATA(LTOT)
- SET LTOT="0.00"
- +31 IF '$DATA(CNDSP)
- SET CNDSP="0.00"
- +32 ;
- +33 SET ^XTMP(PSUIVSUB,"PBTOT")=LDSP_U_LREC_U_LDES_U_CLAN_U_NDSP_U_LTOT_U_CNDSP
- +34 ;
- +35 QUIT
- +36 ;
- REC ;Place contents of arrays into ^XTMP globals
- +1 ;
- +2 ;PB RECORDS
- MERGE ^XTMP(PSUIVSUB,"PB",PSUDIV)=PSUIVA(PSUDIV)
- +3 ;
- +4 QUIT