IB20P142 ;ALB/BGA - IB V2.0 POST INIT,ADD/EDIT ENTRIES #351.51 ; 3-8-2001
;;2.0;INTEGRATED BILLING;**142**;21-MAR-94
;
; Post Init Description: This init will UPDATE two existing entries
; in file #351.51 and also add one new entry to the same file.
; file 399.1. This post init is associated with path *142*.
;
; Control Logic
D NEWAT ; Added new entry to #351.51
D EDIT ; Edit entries in #351.51
D LAST ; End Task
Q
;
;
NEWAT ; Add new IB CHAMPUS Error Codes into file #351.51
D BMES^XPDUTL(">>>Adding new IB CHAMPUS error codes into file #351.51")
F IBI=1:1 S IBCR=$P($T(NEW+IBI),";;",2) Q:IBCR="QUIT" D
.S (X,IBSYS)=$P(IBCR,"^"),IBCODE=$P(IBCR,"^",2)
.I $D(^IBE(351.51,"AD",IBSYS,IBCODE)) D Q
. . D BMES^XPDUTL(" >>Error Code '"_IBCODE_"' is already on file for the "_IBSYS_" system.")
.K DD,DO S DIC="^IBE(351.51,",DIC(0)="" D FILE^DICN Q:Y<0
.S ^(0)=^IBE(351.51,+Y,0)_"^"_$P(IBCR,U,2,3) S DIK=DIC,DA=+Y D IX1^DIK
.D BMES^XPDUTL(" >>Error Code '"_IBCODE_"' for the '"_IBSYS_"' System has been filed.")
K DA,DIC,DIE,DIK,DR,IBI,IBCR,IBCODE,IBSYS,X,Y,Z
Q
;
NEW ; Action Types to add into file #351.51
;;UNIVERSAL^M6^Out of Region
;;QUIT
;
EDIT ; Edit entries in IB CHAMPUS Error Codes
N I,IBC51,IBIT,IBROW,IBSYSE,IBUP
D BMES^XPDUTL(">>>Searching for IB CHAMPUS ERROR Codes to UPDATE")
F IBIT=1:1 S IBROW=$P($T(MOD+IBIT),";;",2) Q:IBROW="QUIT" D
. S IBC51=$P(IBROW,U,2),IBSYSE=$P(IBROW,U)
. I (IBC51="O5")!(IBC51="O6") D
. . I $D(^IBE(351.51,"AD",IBSYSE,IBC51)) D
. . . S DA=$O(^IBE(351.51,"AD",IBSYSE,IBC51,0)) Q:'DA
. . . S IBUP="0"_$E(IBC51,2),DIE="^IBE(351.51,",DR=".02////"_IBUP
. . . D ^DIE K DIE,DA,DR
. . . D BMES^XPDUTL(" >> "_IBSYSE_" Error Code '"_IBC51_"' has been UPDATED to '"_IBUP_"'")
;
I '$D(IBUP) D BMES^XPDUTL(" >>Codes are CORRECT no MODIFICATIONS required.")
Q
;
MOD ; Edit entries that are currently incorrect in file #351.51
;;MLINK^O5^Bad Invalid Data bits Setting
;;UNIVERSAL^O6^Out of Region
;;QUIT
;
LAST ;
D BMES^XPDUTL(">>>ALL POST-INIT Activities have been completed. <<<")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P142 2120 printed Apr 09, 2024@21:36:47 Page 2
IB20P142 ;ALB/BGA - IB V2.0 POST INIT,ADD/EDIT ENTRIES #351.51 ; 3-8-2001
+1 ;;2.0;INTEGRATED BILLING;**142**;21-MAR-94
+2 ;
+3 ; Post Init Description: This init will UPDATE two existing entries
+4 ; in file #351.51 and also add one new entry to the same file.
+5 ; file 399.1. This post init is associated with path *142*.
+6 ;
+7 ; Control Logic
+8 ; Added new entry to #351.51
DO NEWAT
+9 ; Edit entries in #351.51
DO EDIT
+10 ; End Task
DO LAST
+11 QUIT
+12 ;
+13 ;
NEWAT ; Add new IB CHAMPUS Error Codes into file #351.51
+1 DO BMES^XPDUTL(">>>Adding new IB CHAMPUS error codes into file #351.51")
+2 FOR IBI=1:1
SET IBCR=$PIECE($TEXT(NEW+IBI),";;",2)
if IBCR="QUIT"
QUIT
Begin DoDot:1
+3 SET (X,IBSYS)=$PIECE(IBCR,"^")
SET IBCODE=$PIECE(IBCR,"^",2)
+4 IF $DATA(^IBE(351.51,"AD",IBSYS,IBCODE))
Begin DoDot:2
+5 DO BMES^XPDUTL(" >>Error Code '"_IBCODE_"' is already on file for the "_IBSYS_" system.")
End DoDot:2
QUIT
+6 KILL DD,DO
SET DIC="^IBE(351.51,"
SET DIC(0)=""
DO FILE^DICN
if Y<0
QUIT
+7 SET ^(0)=^IBE(351.51,+Y,0)_"^"_$PIECE(IBCR,U,2,3)
SET DIK=DIC
SET DA=+Y
DO IX1^DIK
+8 DO BMES^XPDUTL(" >>Error Code '"_IBCODE_"' for the '"_IBSYS_"' System has been filed.")
End DoDot:1
+9 KILL DA,DIC,DIE,DIK,DR,IBI,IBCR,IBCODE,IBSYS,X,Y,Z
+10 QUIT
+11 ;
NEW ; Action Types to add into file #351.51
+1 ;;UNIVERSAL^M6^Out of Region
+2 ;;QUIT
+3 ;
EDIT ; Edit entries in IB CHAMPUS Error Codes
+1 NEW I,IBC51,IBIT,IBROW,IBSYSE,IBUP
+2 DO BMES^XPDUTL(">>>Searching for IB CHAMPUS ERROR Codes to UPDATE")
+3 FOR IBIT=1:1
SET IBROW=$PIECE($TEXT(MOD+IBIT),";;",2)
if IBROW="QUIT"
QUIT
Begin DoDot:1
+4 SET IBC51=$PIECE(IBROW,U,2)
SET IBSYSE=$PIECE(IBROW,U)
+5 IF (IBC51="O5")!(IBC51="O6")
Begin DoDot:2
+6 IF $DATA(^IBE(351.51,"AD",IBSYSE,IBC51))
Begin DoDot:3
+7 SET DA=$ORDER(^IBE(351.51,"AD",IBSYSE,IBC51,0))
if 'DA
QUIT
+8 SET IBUP="0"_$EXTRACT(IBC51,2)
SET DIE="^IBE(351.51,"
SET DR=".02////"_IBUP
+9 DO ^DIE
KILL DIE,DA,DR
+10 DO BMES^XPDUTL(" >> "_IBSYSE_" Error Code '"_IBC51_"' has been UPDATED to '"_IBUP_"'")
End DoDot:3
End DoDot:2
End DoDot:1
+11 ;
+12 IF '$DATA(IBUP)
DO BMES^XPDUTL(" >>Codes are CORRECT no MODIFICATIONS required.")
+13 QUIT
+14 ;
MOD ; Edit entries that are currently incorrect in file #351.51
+1 ;;MLINK^O5^Bad Invalid Data bits Setting
+2 ;;UNIVERSAL^O6^Out of Region
+3 ;;QUIT
+4 ;
LAST ;
+1 DO BMES^XPDUTL(">>>ALL POST-INIT Activities have been completed. <<<")
+2 QUIT
