Routine: IB20P330

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)

M(Y) ; sets up messages

 ; Y = text to set up

 S IBL=IBL+1,IBM(IBL)=Y

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  Mar 13, 2025@21:06:56                                                                                                                                                                                                    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

IB20P330.m