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