IB20P330 ;BPFO/OEC-POST INIT ROUTINE FOR IB*2*330 ; 11/15/05 11:21am
;;2.0;INTEGRATED BILLING;**330**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;
POST ; Post Init part of routine to add new rates to 350.2
;
N DIC,DIK,DA,X,Y,IBX,IBA,IBT,IBY,DO,IBC,IBM,IBL,IBUP,IBY1
;
S IBL=0 D M(""),M(" IB*2*330 Post-Install Starting ....."),M(""),MES^XPDUTL(.IBM) K IBM S (IBL,IBT)=0
;
; loop through entries to add (if needed)
RATE F IBX=1:1 S IBY=$P($T(RATES+IBX),";",3) Q:IBY="" D
. ;
. ; see if it is there already
. S IBA=$O(^IBE(350.1,"B",$P(IBY,"^",3),0))
. I 'IBA D M(" ** Error: IB Action type "_$P(IBX,"^",3)_" not found !!!") Q
. S $P(IBY,"^",3)=IBA
. S IBC=$O(^IBE(350.2,"AIVDT",IBA,-$P(IBY,"^",2),0))
. ;
. ; add new entry
. I 'IBC S DIC="^IBE(350.2,",DIC(0)="",X=$P(IBY,"^") K DO D FILE^DICN I $P(Y,"^",3) S $P(IBT,"^")=IBT+1,IBC=+Y
. I 'IBC D M(" ** Error: Unable to add rate for "_$P(IBY,"^")) Q
. ;
. ; file data and xref
. S ^IBE(350.2,+IBC,0)=IBY,DA=IBC,DIK="^IBE(350.2," D IX^DIK
;
;
D M(" "_IBT_" rates added to IB ACTION CHARGE file."),M(" ")
D MES^XPDUTL(.IBM) K IBM S IBL=0
;
;
S IBT=0
;
; loop through entries to add (if needed)
CAP F IBX=1:1 S IBY=$P($T(CAPS+IBX),";",3) Q:IBY="" D
. ;
. ; see if it is there already
. S IBA=$O(^IBAM(354.75,"AC",$P(IBY,"^",3),$P(IBY,"^",2),0))
. I IBA S IBC=$G(^IBAM(354.75,IBA,0)) I IBC=$P(IBY,"^",2,7) Q
. ;
. I IBA D M(" ** Error: Entry Number "_IBA_" in file 354.75 is incorrect !!!") Q
. ;
. ; add new entry
. S DIC="^IBAM(354.75,",DIC(0)="",X=$P(IBY,"^",2) K DO D FILE^DICN S IBY1=+Y K D0
. I Y<0 D M(" ** Error: Unable to add entry "_$P(IBY,"^")_" in file 354.75 !!!") Q
. ;
. ; file data and xref
. S ^IBAM(354.75,IBY1,0)=$P(IBY,"^",2,7),DA=IBY1,DIK="^IBAM(354.75," D IX^DIK S IBT=IBT+1
;
D M(" "_IBT_" caps added to IB COPAY CAPS file."),M(" ")
D MES^XPDUTL(.IBM) K IBM,IBY1 S IBL=0
;
D M(" IB*2*330 Post-Install Done .....")
D MES^XPDUTL(.IBM)
;
Q
;
M(Y) ; sets up messages
; Y = text to set up
S IBL=IBL+1,IBM(IBL)=Y
Q
;
RATES ; copay rates to add
;;RX1^3060101^PSO NSC RX COPAY NEW^8
;;RX3^3060101^PSO NSC RX COPAY CANCEL^8
;;RX4^3060101^PSO NSC RX COPAY UPDATE^8
;;RX2^3060101^PSO SC RX COPAY NEW^8
;;RX5^3060101^PSO SC RX COPAY CANCEL^8
;;RX6^3060101^PSO SC RX COPAY UPDATE^8
;;
CAPS ; copay caps to be installed (added) (same format as in 354.75 dd)
;;1^3060101^2^^960^^C
;;2^3060101^3^^960^^C
;;3^3060101^4^^960^^C
;;4^3060101^5^^960^^C
;;5^3060101^6^^960^^C
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P330 2611 printed Oct 16, 2024@18:02:52 Page 2
IB20P330 ;BPFO/OEC-POST INIT ROUTINE FOR IB*2*330 ; 11/15/05 11:21am
+1 ;;2.0;INTEGRATED BILLING;**330**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;
POST ; Post Init part of routine to add new rates to 350.2
+1 ;
+2 NEW DIC,DIK,DA,X,Y,IBX,IBA,IBT,IBY,DO,IBC,IBM,IBL,IBUP,IBY1
+3 ;
+4 SET IBL=0
DO M("")
DO M(" IB*2*330 Post-Install Starting .....")
DO M("")
DO MES^XPDUTL(.IBM)
KILL IBM
SET (IBL,IBT)=0
+5 ;
+6 ; loop through entries to add (if needed)
RATE FOR IBX=1:1
SET IBY=$PIECE($TEXT(RATES+IBX),";",3)
if IBY=""
QUIT
Begin DoDot:1
+1 ;
+2 ; see if it is there already
+3 SET IBA=$ORDER(^IBE(350.1,"B",$PIECE(IBY,"^",3),0))
+4 IF 'IBA
DO M(" ** Error: IB Action type "_$PIECE(IBX,"^",3)_" not found !!!")
QUIT
+5 SET $PIECE(IBY,"^",3)=IBA
+6 SET IBC=$ORDER(^IBE(350.2,"AIVDT",IBA,-$PIECE(IBY,"^",2),0))
+7 ;
+8 ; add new entry
+9 IF 'IBC
SET DIC="^IBE(350.2,"
SET DIC(0)=""
SET X=$PIECE(IBY,"^")
KILL DO
DO FILE^DICN
IF $PIECE(Y,"^",3)
SET $PIECE(IBT,"^")=IBT+1
SET IBC=+Y
+10 IF 'IBC
DO M(" ** Error: Unable to add rate for "_$PIECE(IBY,"^"))
QUIT
+11 ;
+12 ; file data and xref
+13 SET ^IBE(350.2,+IBC,0)=IBY
SET DA=IBC
SET DIK="^IBE(350.2,"
DO IX^DIK
End DoDot:1
+14 ;
+15 ;
+16 DO M(" "_IBT_" rates added to IB ACTION CHARGE file.")
DO M(" ")
+17 DO MES^XPDUTL(.IBM)
KILL IBM
SET IBL=0
+18 ;
+19 ;
+20 SET IBT=0
+21 ;
+22 ; loop through entries to add (if needed)
CAP FOR IBX=1:1
SET IBY=$PIECE($TEXT(CAPS+IBX),";",3)
if IBY=""
QUIT
Begin DoDot:1
+1 ;
+2 ; see if it is there already
+3 SET IBA=$ORDER(^IBAM(354.75,"AC",$PIECE(IBY,"^",3),$PIECE(IBY,"^",2),0))
+4 IF IBA
SET IBC=$GET(^IBAM(354.75,IBA,0))
IF IBC=$PIECE(IBY,"^",2,7)
QUIT
+5 ;
+6 IF IBA
DO M(" ** Error: Entry Number "_IBA_" in file 354.75 is incorrect !!!")
QUIT
+7 ;
+8 ; add new entry
+9 SET DIC="^IBAM(354.75,"
SET DIC(0)=""
SET X=$PIECE(IBY,"^",2)
KILL DO
DO FILE^DICN
SET IBY1=+Y
KILL D0
+10 IF Y<0
DO M(" ** Error: Unable to add entry "_$PIECE(IBY,"^")_" in file 354.75 !!!")
QUIT
+11 ;
+12 ; file data and xref
+13 SET ^IBAM(354.75,IBY1,0)=$PIECE(IBY,"^",2,7)
SET DA=IBY1
SET DIK="^IBAM(354.75,"
DO IX^DIK
SET IBT=IBT+1
End DoDot:1
+14 ;
+15 DO M(" "_IBT_" caps added to IB COPAY CAPS file.")
DO M(" ")
+16 DO MES^XPDUTL(.IBM)
KILL IBM,IBY1
SET IBL=0
+17 ;
+18 DO M(" IB*2*330 Post-Install Done .....")
+19 DO MES^XPDUTL(.IBM)
+20 ;
+21 QUIT
+22 ;
M(Y) ; sets up messages
+1 ; Y = text to set up
+2 SET IBL=IBL+1
SET IBM(IBL)=Y
+3 QUIT
+4 ;
RATES ; copay rates to add
+1 ;;RX1^3060101^PSO NSC RX COPAY NEW^8
+2 ;;RX3^3060101^PSO NSC RX COPAY CANCEL^8
+3 ;;RX4^3060101^PSO NSC RX COPAY UPDATE^8
+4 ;;RX2^3060101^PSO SC RX COPAY NEW^8
+5 ;;RX5^3060101^PSO SC RX COPAY CANCEL^8
+6 ;;RX6^3060101^PSO SC RX COPAY UPDATE^8
+7 ;;
CAPS ; copay caps to be installed (added) (same format as in 354.75 dd)
+1 ;;1^3060101^2^^960^^C
+2 ;;2^3060101^3^^960^^C
+3 ;;3^3060101^4^^960^^C
+4 ;;4^3060101^5^^960^^C
+5 ;;5^3060101^6^^960^^C
