Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSUV7

PSUV7.m

Go to the documentation of this file.
  1. PSUV7 ;BIR/DAM - IV PB AMIS Summary Data ;11 March 2004
  1. ;;4.0;PHARMACY BENEFITS MANAGEMENT;**4,22**;MARCH, 2005;Build 2
  1. ;
  1. ;This routine gathers IV Piggyback AMIS summary data
  1. ;No DBIA's needed
  1. ;
  1. EN ;Entry point to gather AMIS data. Called from PSUV3
  1. ;
  1. K PSUIVA ;Array to hold temporary data
  1. ;
  1. ;Initialize variables for column totals
  1. ;
  1. S (PSUDIV,PSUCT)=0
  1. F S PSUDIV=$O(^XTMP(PSUIVSUB,"RECORDS",PSUDIV)) Q:PSUDIV="" D EN1
  1. Q
  1. ;
  1. EN1 ;EN CONTINUED
  1. ;
  1. S PSUOR=""
  1. N LDSP,LREC,LDES,CLAN,NDSP,LTOT,CNDSP
  1. F S PSUCT=$O(^XTMP(PSUIVSUB,"RECORDS",PSUDIV,PSUCT)) Q:PSUCT="" D
  1. .K PSUAMIS
  1. .M PSUAMIS(PSUDIV,PSUCT)=^XTMP(PSUIVSUB,"RECORDS",PSUDIV,PSUCT)
  1. .;
  1. .S PSUP=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,5) ;Parent record
  1. .;
  1. .S PSUTYP=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,6) ;IV TYPE
  1. .;
  1. .I PSUTYP="P" S PSUOR=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,4)_"^"_$P($G(PSUAMIS(PSUDIV,PSUCT)),U,8) ;IV order #^Patient SSN
  1. .;
  1. .D LVPDSP
  1. .D LVPREC
  1. .D LVPDES
  1. .D LVPCAN
  1. .D LVPNET
  1. .D LVPTOT
  1. .D CNET
  1. .D REC
  1. D TOTAL
  1. ;
  1. Q
  1. ;
  1. LVPDSP ;Gather PB Dispensed data
  1. ;
  1. I PSUTYP="P",PSUP="P" D ;PBs Dispensed
  1. .N DSP
  1. .S DSP=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,29)
  1. .S $P(PSUIVA(PSUDIV),U,1)=$P($G(PSUIVA(PSUDIV)),U,1)+DSP
  1. ;
  1. Q
  1. ;
  1. LVPREC ;Gather PB Recycled data
  1. ;
  1. I PSUTYP="P",PSUP="P" D ;PB's recycled
  1. .N REC
  1. .S REC=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,30)
  1. .S $P(PSUIVA(PSUDIV),U,2)=$P($G(PSUIVA(PSUDIV)),U,2)+REC
  1. ;
  1. Q
  1. ;
  1. LVPDES ;Gather PB Destroyed data
  1. ;
  1. I PSUTYP="P",PSUP="P" D ;PB's destroyed
  1. .N DES
  1. .S DES=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,31)
  1. .S $P(PSUIVA(PSUDIV),U,3)=$P($G(PSUIVA(PSUDIV)),U,3)+DES
  1. ;
  1. Q
  1. ;
  1. LVPCAN ;Gather PB Cancelled data
  1. ;
  1. I PSUTYP="P",PSUP="P" D ;PB's cancelled
  1. .N CAN
  1. .S CAN=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,32)
  1. .S $P(PSUIVA(PSUDIV),U,4)=$P($G(PSUIVA(PSUDIV)),U,4)+CAN
  1. ;
  1. Q
  1. ;
  1. LVPNET ;Calculate net amount of PB's Dispensed
  1. ;
  1. I PSUTYP="P",PSUP="P" D
  1. .N NET
  1. .S NET=$P($G(PSUAMIS(PSUDIV,PSUCT)),U,11)
  1. .S $P(PSUIVA(PSUDIV),U,5)=$P($G(PSUIVA(PSUDIV)),U,5)+NET
  1. Q
  1. ;
  1. LVPTOT ;Calculate Total cost
  1. ;
  1. N NDIS,COST,PSUOR1
  1. S PSUCTA=0
  1. F S PSUCTA=$O(PSUAMIS(PSUDIV,PSUCTA)) Q:PSUCTA="" D
  1. .S PSUOR1=$P(PSUAMIS(PSUDIV,PSUCTA),U,4)_"^"_$P(PSUAMIS(PSUDIV,PSUCTA),U,8)
  1. .Q:(PSUOR1'=PSUOR)
  1. .S NDIS=$P($G(PSUAMIS(PSUDIV,PSUCTA)),U,33)
  1. .S COST=$P($G(PSUAMIS(PSUDIV,PSUCTA)),U,22)
  1. .S $P(PSUIVA(PSUDIV),U,6)=$P($G(PSUIVA(PSUDIV)),U,6)+(NDIS*$G(COST))
  1. .;
  1. .;Truncate cost to 2 decimal places
  1. .N A,B,C
  1. .;
  1. .I $P(PSUIVA(PSUDIV),U,6)'["." D Q
  1. ..S $P(PSUIVA(PSUDIV),U,6)=$P(PSUIVA(PSUDIV),U,6)_".00"
  1. .;
  1. .S A=$F($P(PSUIVA(PSUDIV),U,6),".") ;Find 1st position after decimal
  1. .;
  1. .S B=$E($P(PSUIVA(PSUDIV),U,6),1,(A-1)) ;Extract dollars and decimal
  1. .;
  1. .S C=$E($P(PSUIVA(PSUDIV),U,6),A,(A+1)) ;Extract cents after decimal
  1. .I $L(C)'=2 S C=$E(C,1)_0
  1. .;
  1. .S $P(PSUIVA(PSUDIV),U,6)=B_C
  1. Q
  1. ;
  1. CNET ;Calculate Cost per Net PB's dispensed
  1. ;
  1. N CNET,TCOST
  1. ;
  1. S CNET=$P($G(PSUIVA(PSUDIV)),U,5)
  1. S TCOST=$P($G(PSUIVA(PSUDIV)),U,6)
  1. ;
  1. I CNET'="",CNET'=0,TCOST'="" D
  1. .S $P(PSUIVA(PSUDIV),U,7)=TCOST/CNET
  1. .;
  1. .;Truncate cost to 2 decimal places
  1. .N A,B,C
  1. .;
  1. .I $P(PSUIVA(PSUDIV),U,7)'["." D Q
  1. ..S $P(PSUIVA(PSUDIV),U,7)=$P(PSUIVA(PSUDIV),U,7)_".00"
  1. .;
  1. .S A=$F($P(PSUIVA(PSUDIV),U,7),".") ;Find 1st position after decimal
  1. .;
  1. .S B=$E($P(PSUIVA(PSUDIV),U,7),1,(A-1)) ;Extract dollars and decimal
  1. .;
  1. .S C=$E($P(PSUIVA(PSUDIV),U,7),A,(A+1)) ;Extract cents after decimal
  1. .I $L(C)'=2 S C=$E(C,1)_0
  1. .;
  1. .S $P(PSUIVA(PSUDIV),U,7)=B_C
  1. ;
  1. Q
  1. ;
  1. TOTAL ;Add up column totals and place into ^XTMP global
  1. ;
  1. S PSUDI=0
  1. F S PSUDI=$O(PSUIVA(PSUDI)) Q:PSUDI="" D
  1. .S LDSP=$G(LDSP)+$P(PSUIVA(PSUDI),U,1) ;Total PB's dispensed
  1. .;
  1. .S LREC=$G(LREC)+$P(PSUIVA(PSUDI),U,2) ;Total PB's recycled
  1. .;
  1. .S LDES=$G(LDES)+$P(PSUIVA(PSUDI),U,3) ;Total PB's destroyed
  1. .;
  1. .S CLAN=$G(CLAN)+$P(PSUIVA(PSUDI),U,4) ;Total PB's cancelled
  1. .;
  1. .S NDSP=$G(NDSP)+$P(PSUIVA(PSUDI),U,5) ;Total Net PB's dispensed
  1. .;
  1. .S LTOT=$G(LTOT)+$P(PSUIVA(PSUDI),U,6) ;Total of Total cost
  1. .;
  1. .I $G(NDSP) S CNDSP=$G(LTOT)/NDSP D
  1. ..I CNDSP'["." S CNDSP=CNDSP_".00" Q
  1. ..N A,B,C
  1. ..S A=$F(CNDSP,".") ;Find 1st position after decimal
  1. ..S B=$E(CNDSP,1,(A-1)) ;Extract dollars and decimal
  1. ..S C=$E(CNDSP,A,(A+1)) ;Extract cents after decimal
  1. ..I $L(C)'=2 S C=$E(C,1)_0
  1. ..S CNDSP=B_C
  1. ;
  1. I '$D(LDSP) S LDSP=0
  1. I '$D(LREC) S LREC=0
  1. I '$D(LDES) S LDES=0
  1. I '$D(CLAN) S CLAN=0
  1. I '$D(NDSP) S NDSP=0
  1. I '$D(LTOT) S LTOT="0.00"
  1. I '$D(CNDSP) S CNDSP="0.00"
  1. ;
  1. S ^XTMP(PSUIVSUB,"PBTOT")=LDSP_U_LREC_U_LDES_U_CLAN_U_NDSP_U_LTOT_U_CNDSP
  1. ;
  1. Q
  1. ;
  1. REC ;Place contents of arrays into ^XTMP globals
  1. ;
  1. M ^XTMP(PSUIVSUB,"PB",PSUDIV)=PSUIVA(PSUDIV) ;PB RECORDS
  1. ;
  1. Q