IB20P627.m

IB20P627 ;OAK/ELZ - POST INIT FOR PATCH;06/20/2018 ; 31 Jan 2019  3:24 PM

 ;;2.0;INTEGRATED BILLING;**627**;21-MAR-94;Build 21

 ;;Per VA Directive 6402, this routine should not be modified.

 ;

 ;

POST ; post init entry point

 ;

 D MES^XPDUTL("  Starting post-init for IB*2.0*627")

 ;

 D 3542

 D 3503

 ;

 D MES^XPDUTL("  Finished post-init for IB*2.0*627")

 ;

 Q

 ;

3542 ; add entry to exemption file 354.2 if not there

 I $O(^IBE(354.2,"B","MEDAL OF HONOR",0)) D  Q

 . D MES^XPDUTL("    - MEDAL OF HONOR already exists, nothing to add to 354.2.")

 ;

 N DO,X,Y,DIC

 ;

 S X="MEDAL OF HONOR",DIC="^IBE(354.2,",DIC(0)=""

 S DIC("DR")=".02///Patient awarded Medal of Honor;.03///1;.04///1;.05///50"

 D FILE^DICN

 ;

 D MES^XPDUTL($S(Y>1:"    - MEDAL OF HONOR Exemption Reason (#354.2) added.",1:"*** ERROR: COULD NOT CREATE NEW MOH ENTRY IN 354.2 ***"))

 ;

 Q

 ;

3503 ; add entry to Charge Removal Reason file if not there

 ;

 N IBX,DO,DIC,X,Y

 ;

 D MES^XPDUTL("    - Adding entry to Charge Removal Reason (#350.3) file.")

 S IBX="MEDAL OF HONOR^MOH" D

 . S DIC="^IBE(350.3,",DIC(0)="",X=$P(IBX,"^")

 . S DIC("DR")=".02///^S X=$P(IBX,U,2);.03///3"

 . I $O(^IBE(350.3,"B",X,0)) D MES^XPDUTL("      - "_X_" already exists.") Q

 . D FILE^DICN

 . D MES^XPDUTL($S(Y>1:"      - "_$P(IBX,"^")_" entry added.",1:"*** ERROR: COULD NOT CREATE NEW "_$P(IBX,"^",2)_" ENTRY IN 350.3 ***"))

 ;

 D MES^XPDUTL("    - Done adding entry in Charge Removal Reason (#350.3) file.")

 Q

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IB20P627   1506     printed  Apr 09, 2024@21:21:12                                                                                                                                                                                                    Page 2

IB20P627  ;OAK/ELZ - POST INIT FOR PATCH;06/20/2018 ; 31 Jan 2019  3:24 PM

 +1       ;;2.0;INTEGRATED BILLING;**627**;21-MAR-94;Build 21

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3       ;

 +4       ;

POST      ; post init entry point

 +1       ;

 +2        DO MES^XPDUTL("  Starting post-init for IB*2.0*627")

 +3       ;

 +4        DO 3542

 +5        DO 3503

 +6       ;

 +7        DO MES^XPDUTL("  Finished post-init for IB*2.0*627")

 +8       ;

 +9        QUIT 

 +10      ;

3542      ; add entry to exemption file 354.2 if not there

 +1        IF $ORDER(^IBE(354.2,"B","MEDAL OF HONOR",0))

               Begin DoDot:1

 +2                DO MES^XPDUTL("    - MEDAL OF HONOR already exists, nothing to add to 354.2.")

               End DoDot:1

               QUIT 

 +3       ;

 +4        NEW DO,X,Y,DIC

 +5       ;

 +6        SET X="MEDAL OF HONOR"

           SET DIC="^IBE(354.2,"

           SET DIC(0)=""

 +7        SET DIC("DR")=".02///Patient awarded Medal of Honor;.03///1;.04///1;.05///50"

 +8        DO FILE^DICN

 +9       ;

 +10       DO MES^XPDUTL($SELECT(Y>1:"    - MEDAL OF HONOR Exemption Reason (#354.2) added.",1:"*** ERROR: COULD NOT CREATE NEW MOH ENTRY IN 354.2 ***"))

 +11      ;

 +12       QUIT 

 +13      ;

3503      ; add entry to Charge Removal Reason file if not there

 +1       ;

 +2        NEW IBX,DO,DIC,X,Y

 +3       ;

 +4        DO MES^XPDUTL("    - Adding entry to Charge Removal Reason (#350.3) file.")

 +5        SET IBX="MEDAL OF HONOR^MOH"

           Begin DoDot:1

 +6            SET DIC="^IBE(350.3,"

               SET DIC(0)=""

               SET X=$PIECE(IBX,"^")

 +7            SET DIC("DR")=".02///^S X=$P(IBX,U,2);.03///3"

 +8            IF $ORDER(^IBE(350.3,"B",X,0))

                   DO MES^XPDUTL("      - "_X_" already exists.")

                   QUIT 

 +9            DO FILE^DICN

 +10           DO MES^XPDUTL($SELECT(Y>1:"      - "_$PIECE(IBX,"^")_" entry added.",1:"*** ERROR: COULD NOT CREATE NEW "_$PIECE(IBX,"^",2)_" ENTRY IN 350.3 ***"))

           End DoDot:1

 +11      ;

 +12       DO MES^XPDUTL("    - Done adding entry in Charge Removal Reason (#350.3) file.")

 +13       QUIT 

 +14      ;