Routine: IB20P429

IB20P429 ;ELZ/OAK - POST INIT FOR PATCH;11/10/09

 ;;2.0;INTEGRATED BILLING;**429**;21-MAR-94;Build 62

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

POST ; loop through and populate entries in 350.2 if not there

 N IBX,IBZ,IBC,DO,IBE,X,Y,DIC,IBY,DIK,DA

 S IBC=0

 F IBX=1:1 S IBZ=$P($T(3502+IBX),";",3) Q:IBZ=""  D

 . S IBE=$O(^IBE(350.1,"B",$P(IBZ,"^",3),0))

 . I 'IBE D MES^XPDUTL("ERROR: Unable to find IB ACTION TYPE: "_$P(IBZ,"^",3)) Q

 . S $P(IBZ,"^",3)=IBE

 . I $D(^IBE(350.2,"AIVDT",$P(IBZ,"^",3),-$P(IBZ,"^",2))) Q

 . S X=$P(IBZ,"^"),DIC="^IBE(350.2,",DIC(0)="" D FILE^DICN

 . S IBY=+Y I Y<1 D MES^XPDUTL("ERROR: Unable to add IB ACTION CHARGE: "_$P(IBZ,"^")) Q

 . S ^IBE(350.2,IBY,0)=IBZ

 . S DIK="^IBE(350.2,",DA=IBY D IX^DIK

 . ; set additional amount IF logic

 . S ^IBE(350.2,IBY,20)="I $G(DFN)>0,$$PRIORITY^DGENA(DFN)>6"

 . S IBC=IBC+1

 D MES^XPDUTL(IBC_" entries added to IB ACTION CHARGE (#350.2) file.")

3502 ; data for 350.2 entries to be added

 ;;RX1^3100701^PSO NSC RX COPAY NEW^8^^1

 ;;RX2^3100701^PSO SC RX COPAY NEW^8^^1

 ;;RX3^3100701^PSO NSC RX COPAY CANCEL^8^^1

 ;;RX4^3100701^PSO NSC RX COPAY UPDATE^8^^1

 ;;RX5^3100701^PSO SC RX COPAY CANCEL^8^^1

 ;;RX6^3100701^PSO SC RX COPAY UPDATE^8^^1

;;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P429   1301     printed  Feb 18, 2025@23:29:13                                                                                                                                                                                                    Page 2

IB20P429  ;ELZ/OAK - POST INIT FOR PATCH;11/10/09

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

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

 +3       ;

 +4       ;

POST      ; loop through and populate entries in 350.2 if not there

 +1       ;

 +2        NEW IBX,IBZ,IBC,DO,IBE,X,Y,DIC,IBY,DIK,DA

 +3        SET IBC=0

 +4        FOR IBX=1:1

               SET IBZ=$PIECE($TEXT(3502+IBX),";",3)

               if IBZ=""

                   QUIT

               Begin DoDot:1

 +5                SET IBE=$ORDER(^IBE(350.1,"B",$PIECE(IBZ,"^",3),0))

 +6                IF 'IBE

                       DO MES^XPDUTL("ERROR: Unable to find IB ACTION TYPE: "_$PIECE(IBZ,"^",3))

                       QUIT

 +7                SET $PIECE(IBZ,"^",3)=IBE

 +8                IF $DATA(^IBE(350.2,"AIVDT",$PIECE(IBZ,"^",3),-$PIECE(IBZ,"^",2)))

                       QUIT

 +9                SET X=$PIECE(IBZ,"^")

                   SET DIC="^IBE(350.2,"

                   SET DIC(0)=""

                   DO FILE^DICN

 +10               SET IBY=+Y

                   IF Y<1

                       DO MES^XPDUTL("ERROR: Unable to add IB ACTION CHARGE: "_$PIECE(IBZ,"^"))

                       QUIT

 +11               SET ^IBE(350.2,IBY,0)=IBZ

 +12               SET DIK="^IBE(350.2,"

                   SET DA=IBY

                   DO IX^DIK

 +13      ; set additional amount IF logic

 +14               SET ^IBE(350.2,IBY,20)="I $G(DFN)>0,$$PRIORITY^DGENA(DFN)>6"

 +15               SET IBC=IBC+1

               End DoDot:1

 +16      ;

 +17       DO MES^XPDUTL(IBC_" entries added to IB ACTION CHARGE (#350.2) file.")

 +18      ;

 +19       QUIT

 +20      ;

3502      ; data for 350.2 entries to be added

 +1       ;;RX1^3100701^PSO NSC RX COPAY NEW^8^^1

 +2       ;;RX2^3100701^PSO SC RX COPAY NEW^8^^1

 +3       ;;RX3^3100701^PSO NSC RX COPAY CANCEL^8^^1

 +4       ;;RX4^3100701^PSO NSC RX COPAY UPDATE^8^^1

 +5       ;;RX5^3100701^PSO SC RX COPAY CANCEL^8^^1

 +6       ;;RX6^3100701^PSO SC RX COPAY UPDATE^8^^1

 +7       ;;

 +8       ;

IB20P429.m