- 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 23, 2025@18:16:08 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
