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.")
;
Q
;
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 Dec 13, 2024@02:02:51 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 ;
