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 Nov 22, 2024@17:14:04 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 ;;
