- IB20P590 ;OAK/ELZ - IB*2*590 INSTALL ROUTINE ;1-MAR-2017
- ;;2.0;INTEGRATED BILLING;**590**;21-MAR-94;Build 3
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- POSTINT ; - post-install
- D BMES^XPDUTL("Starting Post-install")
- D OLDCH
- D NEWCH
- D BMES^XPDUTL("Post-install finished")
- Q
- ;
- OLDCH ; - populate old action type charges
- ;
- D BMES^XPDUTL("Populating default tier into old Fee Prescription IB Action Charges")
- ;
- ; this will loop through all old fee 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,11)'="FEE SERV 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 Fee Action Charges updated")
- Q
- ;
- NEWCH ; - populate new action type charges
- ;
- D BMES^XPDUTL("Adding new Fee 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 Fee Prescription IB Action Charges")
- Q
- ;
- DATA3502 ; - data for the new 350.2 entries
- ; format key^eff date^action type (350.1)^unit charge^tier
- ;;FEE SERV RX1^3170227^FEE SERV NSC RX COPAY NEW^5^1
- ;;FEE SERV RX3^3170227^FEE SERV NSC RX COPAY CANCEL^5^1
- ;;FEE SERV RX4^3170227^FEE SERV NSC RX COPAY UPDATE^5^1
- ;;FEE SERV RX1^3170227^FEE SERV NSC RX COPAY NEW^8^2
- ;;FEE SERV RX3^3170227^FEE SERV NSC RX COPAY CANCEL^8^2
- ;;FEE SERV RX4^3170227^FEE SERV NSC RX COPAY UPDATE^8^2
- ;;FEE SERV RX1^3170227^FEE SERV NSC RX COPAY NEW^11^3
- ;;FEE SERV RX3^3170227^FEE SERV NSC RX COPAY CANCEL^11^3
- ;;FEE SERV RX4^3170227^FEE SERV NSC RX COPAY UPDATE^11^3
- ;;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P590 2373 printed Mar 13, 2025@21:08:44 Page 2
- IB20P590 ;OAK/ELZ - IB*2*590 INSTALL ROUTINE ;1-MAR-2017
- +1 ;;2.0;INTEGRATED BILLING;**590**;21-MAR-94;Build 3
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- POSTINT ; - post-install
- +1 DO BMES^XPDUTL("Starting Post-install")
- +2 DO OLDCH
- +3 DO NEWCH
- +4 DO BMES^XPDUTL("Post-install finished")
- +5 QUIT
- +6 ;
- OLDCH ; - populate old action type charges
- +1 ;
- +2 DO BMES^XPDUTL("Populating default tier into old Fee Prescription IB Action Charges")
- +3 ;
- +4 ; this will loop through all old fee 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,11)'="FEE SERV 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 Fee Action Charges updated")
- +13 QUIT
- +14 ;
- NEWCH ; - populate new action type charges
- +1 ;
- +2 DO BMES^XPDUTL("Adding new Fee 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 Fee Prescription IB Action Charges")
- +19 QUIT
- +20 ;
- DATA3502 ; - data for the new 350.2 entries
- +1 ; format key^eff date^action type (350.1)^unit charge^tier
- +2 ;;FEE SERV RX1^3170227^FEE SERV NSC RX COPAY NEW^5^1
- +3 ;;FEE SERV RX3^3170227^FEE SERV NSC RX COPAY CANCEL^5^1
- +4 ;;FEE SERV RX4^3170227^FEE SERV NSC RX COPAY UPDATE^5^1
- +5 ;;FEE SERV RX1^3170227^FEE SERV NSC RX COPAY NEW^8^2
- +6 ;;FEE SERV RX3^3170227^FEE SERV NSC RX COPAY CANCEL^8^2
- +7 ;;FEE SERV RX4^3170227^FEE SERV NSC RX COPAY UPDATE^8^2
- +8 ;;FEE SERV RX1^3170227^FEE SERV NSC RX COPAY NEW^11^3
- +9 ;;FEE SERV RX3^3170227^FEE SERV NSC RX COPAY CANCEL^11^3
- +10 ;;FEE SERV RX4^3170227^FEE SERV NSC RX COPAY UPDATE^11^3
- +11 ;;
