Routine: IB20P449

IB20P449 ;ELZ/OAK - POST INIT FOR PATCH;02/22/2011

 ;;2.0;INTEGRATED BILLING;**449**;21-MAR-94;Build 15

 ;;Per VHA Directive 2004-038, this routine should not be modified.

ENV ;

 ; setup so no queue of install

 S XPDNOQUE=1

POST ; post init entry point

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

 D 3542

 D 3503

 D REPORT

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

3542 ; add entry to exemption file 354.2 if not there

 I $O(^IBE(354.2,"B","CATASTROPHICALLY DISABLED",0)) D  Q

 . D MES^XPDUTL("    - CATASTROPHICALLY DISABLED already exists, nothing to add to 354.2.")

 N DO,X,Y,DIC

 S X="CATASTROPHICALLY DISABLED",DIC="^IBE(354.2,",DIC(0)=""

 S DIC("DR")=".02///Patient is Catastrophically Disabled;.03///1;.04///1;.05///100"

 D FILE^DICN

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

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="CATASTROPHICALLY DISABLED^CD" D

 . K DO 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.")

REPORT ; - this will produce a report of patient's with charges that are CD.

 N POP,%ZIS,ZTRTN,ZTDESC,ZTSK,IBA,IBEDT,IBBDT,ZTSAVE

 S IBBDT=3100504,IBEDT=DT

 S IBA(1)="Select the device for the Catastrophically Disabled Charge report.  It"

 S IBA(2)="should be queued to a printer off hours as it can take some time to run"

 S IBA(3)="with at least a margin of 132 columns."

 D MES^XPDUTL(.IBA)

 S %ZIS="QM" D ^%ZIS Q:POP

 I $D(IO("Q")) D  Q

 .S ZTRTN="DQ^IBOCDRPT",ZTDESC="Catastrophically Disabled Copay Report"

 .S (ZTSAVE("IBEDT"),ZTSAVE("IBBDT"))=""

 .D ^%ZTLOAD D HOME^%ZIS K IO("Q")

 .D MES^XPDUTL("Catastrophically Disabled Copay Report queued #"_ZTSK)

 D DQ^IBOCDRPT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P449   2324     printed  Mar 13, 2025@21:07:44                                                                                                                                                                                                    Page 2

IB20P449  ;ELZ/OAK - POST INIT FOR PATCH;02/22/2011

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

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;

 +4       ;

ENV       ;

 +1       ; setup so no queue of install

 +2        SET XPDNOQUE=1

 +3        QUIT

 +4       ;

POST      ; post init entry point

 +1       ;

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

 +3       ;

 +4        DO 3542

 +5        DO 3503

 +6        DO REPORT

 +7       ;

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

 +9       ;

 +10       QUIT

 +11      ;

3542      ; add entry to exemption file 354.2 if not there

 +1        IF $ORDER(^IBE(354.2,"B","CATASTROPHICALLY DISABLED",0))

               Begin DoDot:1

 +2                DO MES^XPDUTL("    - CATASTROPHICALLY DISABLED already exists, nothing to add to 354.2.")

               End DoDot:1

               QUIT

 +3       ;

 +4        NEW DO,X,Y,DIC

 +5       ;

 +6        SET X="CATASTROPHICALLY DISABLED"

           SET DIC="^IBE(354.2,"

           SET DIC(0)=""

 +7        SET DIC("DR")=".02///Patient is Catastrophically Disabled;.03///1;.04///1;.05///100"

 +8        DO FILE^DICN

 +9       ;

 +10       DO MES^XPDUTL($SELECT(Y>1:"    - CATASTROPHICALLY DISABLED Exemption Reason (#354.2) added.",1:"*** ERROR: COULD NOT CREATE NEW CD 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="CATASTROPHICALLY DISABLED^CD"

           Begin DoDot:1

 +6            KILL DO

               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      ;

REPORT    ; - this will produce a report of patient's with charges that are CD.

 +1       ;

 +2        NEW POP,%ZIS,ZTRTN,ZTDESC,ZTSK,IBA,IBEDT,IBBDT,ZTSAVE

 +3        SET IBBDT=3100504

           SET IBEDT=DT

 +4        SET IBA(1)="Select the device for the Catastrophically Disabled Charge report.  It"

 +5        SET IBA(2)="should be queued to a printer off hours as it can take some time to run"

 +6        SET IBA(3)="with at least a margin of 132 columns."

 +7        DO MES^XPDUTL(.IBA)

 +8        SET %ZIS="QM"

           DO ^%ZIS

           if POP

               QUIT

 +9        IF $DATA(IO("Q"))

               Begin DoDot:1

 +10               SET ZTRTN="DQ^IBOCDRPT"

                   SET ZTDESC="Catastrophically Disabled Copay Report"

 +11               SET (ZTSAVE("IBEDT"),ZTSAVE("IBBDT"))=""

 +12               DO ^%ZTLOAD

                   DO HOME^%ZIS

                   KILL IO("Q")

 +13               DO MES^XPDUTL("Catastrophically Disabled Copay Report queued #"_ZTSK)

               End DoDot:1

               QUIT

 +14       DO DQ^IBOCDRPT

 +15       QUIT

IB20P449.m