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

IB20P563.m

Go to the documentation of this file.
  1. IB20P563 ;OAK/ELZ - IB*2*563 INSTALL ROUTINE ;17-MAR-2016
  1. ;;2.0;INTEGRATED BILLING;**563**;21-MAR-94;Build 12
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. PREINT ; - pre-install
  1. ;
  1. ; - delete old unused fields to be replaced by install
  1. D BMES^XPDUTL("Removing old unused fields to be replaced")
  1. N DIK,DA
  1. S DIK="^DD(350,",DA=.22,DA(1)=350
  1. D ^DIK
  1. D BMES^XPDUTL("Field .22 in file 350 removed.")
  1. S DIK="^DD(354.71,",DA=.2,DA(1)=354.71
  1. D ^DIK
  1. D BMES^XPDUTL("Field .2 in file 354.71 removed.")
  1. Q
  1. ;
  1. POSTINT ; - post-install
  1. D BMES^XPDUTL("Starting Post-install")
  1. D OLDCH
  1. D NEWCH
  1. D NEWCAP
  1. D BMES^XPDUTL("Post-install finished")
  1. Q
  1. ;
  1. OLDCH ; - populate old action type charges
  1. ;
  1. D BMES^XPDUTL("Populating default tier into old prescription IB Action Charges")
  1. ;
  1. ; this will loop through all old pharmacy action types and populate the default tier of 2
  1. N IBX,IBC,IBZ,DIE,DA,DR
  1. S (IBC,IBX)=0 F S IBX=$O(^IBE(350.2,IBX)) Q:'IBX D
  1. . S IBZ=$G(^IBE(350.2,IBX,0)) Q:$E(IBZ,1,2)'="RX"
  1. . Q:$P(IBZ,"^",2)>3170101
  1. . Q:$P(IBZ,"^",7)
  1. . S DIE="^IBE(350.2,",DA=IBX,DR=".07///2" D ^DIE
  1. . S IBC=IBC+1
  1. D BMES^XPDUTL(IBC_" IB Action Charges updated")
  1. Q
  1. ;
  1. NEWCH ; - populate new action type charges
  1. ;
  1. D BMES^XPDUTL("Adding new prescription IB Action Charges")
  1. N IBC,IBI,IBX,DO,IBTIER,IBATYPE,DIC,X,IBCHRG,IBDT,Y
  1. S IBC=0
  1. F IBI=2:1 S IBX=$P($T(DATA3502+IBI),";;",2) Q:IBX="" D
  1. . S IBDT=$P(IBX,"^",2),IBTIER=$P(IBX,"^",5),IBCHRG=$P(IBX,"^",4)
  1. . S IBATYPE=$O(^IBE(350.1,"B",$P(IBX,"^",3),0))
  1. . I 'IBATYPE D Q
  1. .. D BMES^XPDUTL("****ERROR: ACTION TYPE (#350.1) "_$P(IBX,"^",3)_" not found!!!")
  1. . Q:$D(^IBE(350.2,"AC",IBATYPE,IBTIER,-IBDT))
  1. . ;
  1. . S X=$P(IBX,"^"),DIC="^IBE(350.2,",DIC(0)=""
  1. . S DIC("DR")=".02///^S X=IBDT;.03///^S X=""`""_IBATYPE;.04///^S X=IBCHRG;.07///^S X=IBTIER"
  1. . D FILE^DICN
  1. . I Y<1 D Q
  1. .. D BMES^XPDUTL("****ERROR: Cannot add charge for Key"_$P(IBX,"^")_" for Tier "_IBTIER_".")
  1. . S IBC=IBC+1
  1. D BMES^XPDUTL("Added "_IBC_" new prescription IB Action Charges")
  1. Q
  1. ;
  1. NEWCAP ; - populate new copayment cap data
  1. ; eff date^pg^amount^basis
  1. D BMES^XPDUTL("Adding new Copay Cap Amounts")
  1. N IBC,IBI,IBX,IBDT,IBPG,IBCAP,IBBAS,X,Y,DIC
  1. S IBC=0
  1. F IBI=2:1 S IBX=$P($T(DATA3547+IBI),";;",2) Q:IBX="" D
  1. . S IBDT=+IBX,IBPG=$P(IBX,"^",2),IBCAP=$P(IBX,"^",3),IBBAS=$P(IBX,"^",4)
  1. . Q:$D(^IBAM(354.75,"AC",IBPG,IBDT))
  1. . ;
  1. . S X=IBDT,DIC="^IBAM(354.75,",DIC(0)=""
  1. . S DIC("DR")=".02///^S X=IBPG;.04///^S X=IBCAP;.06///^S X=IBBAS"
  1. . D FILE^DICN
  1. . I Y<1 D Q
  1. .. D BMES^XPDUTL("****ERROR: Cannot add cap for PG"_IBPG_" effective "_$$FMTE^XLFDT(IBDT))
  1. . S IBC=IBC+1
  1. D BMES^XPDUTL("Added "_IBC_" new Copay Caps")
  1. Q
  1. DATA3502 ; - data for the new 350.2 entries
  1. ; format key^eff date^action type (350.1)^unit charge^tier
  1. ;;RX1^3170227^PSO NSC RX COPAY NEW^5^1
  1. ;;RX2^3170227^PSO SC RX COPAY NEW^5^1
  1. ;;RX3^3170227^PSO NSC RX COPAY CANCEL^5^1
  1. ;;RX4^3170227^PSO NSC RX COPAY UPDATE^5^1
  1. ;;RX5^3170227^PSO SC RX COPAY CANCEL^5^1
  1. ;;RX6^3170227^PSO SC RX COPAY UPDATE^5^1
  1. ;;RX1^3170227^PSO NSC RX COPAY NEW^8^2
  1. ;;RX2^3170227^PSO SC RX COPAY NEW^8^2
  1. ;;RX3^3170227^PSO NSC RX COPAY CANCEL^8^2
  1. ;;RX4^3170227^PSO NSC RX COPAY UPDATE^8^2
  1. ;;RX5^3170227^PSO SC RX COPAY CANCEL^8^2
  1. ;;RX6^3170227^PSO SC RX COPAY UPDATE^8^2
  1. ;;RX1^3170227^PSO NSC RX COPAY NEW^11^3
  1. ;;RX2^3170227^PSO SC RX COPAY NEW^11^3
  1. ;;RX3^3170227^PSO NSC RX COPAY CANCEL^11^3
  1. ;;RX4^3170227^PSO NSC RX COPAY UPDATE^11^3
  1. ;;RX5^3170227^PSO SC RX COPAY CANCEL^11^3
  1. ;;RX6^3170227^PSO SC RX COPAY UPDATE^11^3
  1. ;;
  1. DATA3547 ; - data for the new 354.75 entries
  1. ; format eff date^pg^amount^basis
  1. ;;3170101^2^700^C
  1. ;;3170101^3^700^C
  1. ;;3170101^4^700^C
  1. ;;3170101^5^700^C
  1. ;;3170101^6^700^C
  1. ;;3170101^7^700^C
  1. ;;3170101^8^700^C