IB20P279 ;ISP/TDP - IB*2*279 PRE-INIT ROUTINE ;07/21/2004
;;2.0;INTEGRATED BILLING;**279**;21-MAR-94
;
ENV ; environment check
PRE ; set up check points for pre-init
N %
S %=$$NEWCP^XPDUTL("PROVID","PROVID^IB20P279")
Q
PROVID ;Search files 355.9 and 355.91 for invalid Care Unit pointers to file
;355.96.
D BMES^XPDUTL("Beginning invalid Care Unit pointer search.")
D 3559,35591 I $D(^TMP($J,"IB20P279")) D MESSAGE
D COMPLETE
D END
Q
35591 ;Search file 355.91 for invalid Care Unit pointers to file 355.96.
D BMES^XPDUTL("Searching for invalid Care Unit pointers in file 355.91.")
N DA,DIE,DR,IB35591,IBCARE,IBCIVAL,IBCNT,IBCU,IBCUCHK,IBECNT,IBFORM
N IBINS,IBINSNM,IBNUM,IBPRVID,IBPRVTYP
S (IBCNT,IBECNT,IBNUM)=0
S DIE="^IBA(355.91,"
F S IBNUM=$O(^IBA(355.91,IBNUM)) Q:IBNUM="" D
. I 'IBNUM Q
. S IB35591=$G(^IBA(355.91,IBNUM,0)) I IB35591="" Q
. S IBINS=$P(IB35591,U,1)
. S IBCU=$P(IB35591,U,3) I IBCU="" Q
. S IBFORM=$P(IB35591,U,4)
. S IBCARE=$P(IB35591,U,5)
. S IBPRVID=$P(IB35591,U,6)
. D VALIDCU I IBCIVAL=IBCU Q
. S IBCUCHK=0 D CUCHK I IBCUCHK D Q
.. S IBINSNM=$P($G(^DIC(36,IBINS,0)),U,1) I IBINSNM="" S IBINSNM="UNKNOWN (IEN "_IBINS_")"
.. S IBPRVTYP=$P($G(^IBE(355.97,IBPRVID,0)),U,1)
.. S ^TMP($J,"IB20P279",IBINSNM,IBPRVTYP,"<<INS CO DEFAULT>>",IBNUM)=IB35591
.. S IBECNT=IBECNT+1
.. D OUTPUT
. D FILE
D TOTALS
Q
3559 ;Search file 355.9 for invalid Care Unit pointers to file 355.96.
D BMES^XPDUTL("Searching for invalid Care Unit pointers in file 355.9.")
N DA,DIE,DR,IB3559,IBCARE,IBCIVAL,IBCNT,IBCU,IBCUCHK,IBECNT,IBFORM,IBGBL
N IBINS,IBINSNM,IBNAME,IBNUM,IBPROV,IBPRVID,IBPRVTYP
K ^TMP($J,"IB20P279")
S (IBCNT,IBECNT,IBNUM)=0
S DIE="^IBA(355.9,"
F S IBNUM=$O(^IBA(355.9,IBNUM)) Q:IBNUM="" D
. I 'IBNUM Q
. S IB3559=$G(^IBA(355.9,IBNUM,0)) I IB3559="" Q
. S IBPROV=$P(IB3559,U,1)
. S IBINS=$P(IB3559,U,2)
. S IBCU=$P(IB3559,U,3) I IBCU="" Q
. S IBFORM=$P(IB3559,U,4)
. S IBCARE=$P(IB3559,U,5)
. S IBPRVID=$P(IB3559,U,6)
. D VALIDCU I IBCIVAL=IBCU Q
. S IBCUCHK=0 D CUCHK I IBCUCHK D Q
.. S IBINSNM=$P($G(^DIC(36,IBINS,0)),U,1) I IBINSNM="" S IBINSNM="UNKNOWN (IEN "_IBINS_")"
.. S IBPRVTYP=$P($G(^IBE(355.97,IBPRVID,0)),U,1)
.. S IBGBL="^"_$P($G(IBPROV),";",2)_$P($G(IBPROV),";",1)_",0)"
.. S IBNAME=$P($G(@IBGBL),"^",1)
.. S ^TMP($J,"IB20P279",IBINSNM,IBPRVTYP,IBNAME,IBNUM)=IB3559
.. S IBECNT=IBECNT+1
.. D OUTPUT
. D FILE
D TOTALS
Q
TOTALS ; Print cleanup totals.
N IBFILE
S IBFILE=$S(DIE["355.91":"355.91.",1:"355.9.")
I 'IBCNT,'IBECNT D BMES^XPDUTL("There were no invalid Care Unit pointers in file "_IBFILE) Q
I IBCNT D BMES^XPDUTL(IBCNT_" total invalid Care Unit pointer(s) were corrected in file "_IBFILE)
I IBECNT D BMES^XPDUTL(IBECNT_" total invalid Care Unit pointer(s) were NOT corrected in file "_IBFILE)
Q
OUTPUT ; Failed conversion message.
D MES^XPDUTL("> Cannot change Care Unit Pointer for "_DIE_IBNUM_"). A Mailman")
D MES^XPDUTL(" message will be generated with more information.")
Q
FILE ; Save change and display success message.
N IBL,IBLOCK,X
S IBL=0
S IBLOCK=DIE_IBNUM_")"
F X=1:1:10 L +@IBLOCK:2 H:'$T 5 I $T S IBL=1 Q
I 'IBL D Q
. S IBINSNM=$P($G(^DIC(36,IBINS,0)),U,1) I IBINSNM="" S IBINSNM="UNKNOWN (IEN "_IBINS_")"
. S IBPRVTYP=$P($G(^IBE(355.97,IBPRVID,0)),U,1)
. S IBGBL="^"_$P($G(IBPROV),";",2)_$P($G(IBPROV),";",1)_",0)"
. S IBNAME=$P($G(@IBGBL),"^",1)
. S ^TMP($J,"IB20P279",IBINSNM,IBPRVTYP,IBNAME,IBNUM)=$S($D(IB3559):IB3559,1:IB35591)
. S IBECNT=IBECNT+1
. D OUTPUT
S DA=IBNUM
S DR=".03////"_IBCIVAL
D ^DIE K DA,DR
L -@IBLOCK
D MES^XPDUTL("> Care Unit Pointer for "_DIE_IBNUM_") has been updated.")
S IBCNT=IBCNT+1
Q
VALIDCU ;Checks for valid Care Unit combination.
;Set IBCIVAL to insure Care Unit Pointer (355.9 and 355.91) is correct.
N IBCUVAL
S IBCUVAL=$P($G(^IBA(355.96,+IBCU,0)),U,1) I IBCUVAL="" S IBCIVAL="@" Q
S IBCIVAL=$O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,IBFORM,IBCARE,IBPRVID,"")) I IBCIVAL'="" Q
S IBCIVAL=$O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,IBFORM,0,IBPRVID,"")) I IBCIVAL'="" Q
S IBCIVAL=$O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,IBCARE,IBPRVID,"")) I IBCIVAL'="" Q
S IBCIVAL=$O(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,0,IBPRVID,"")) I IBCIVAL'="" Q
S IBCIVAL="@"
Q
CUCHK ;Checks for existing Care Unit combination.
I DIE="^IBA(355.91,",$D(^IBA(355.91,"AUNIQ",IBINS,$S(IBCIVAL="@":"*N/A*",IBCIVAL:IBCIVAL,1:$P(IB35591,U,10)),IBFORM,IBCARE,IBPRVID)) S IBCUCHK=1
I DIE="^IBA(355.9,",$D(^IBA(355.9,"AUNIQ",IBPROV,IBINS,$S(IBCIVAL="@":"*N/A*",IBCIVAL:IBCIVAL,1:$P(IB3559,U,16)),IBFORM,IBCARE,IBPRVID)) S IBCUCHK=1
Q
MESSAGE ;Send message to user if unable to change Care Unit pointer(s).
N IBC,IBCARE,IBCNT,IBCU,IBDATA,IBFORM,IBGROUP,IBGRP,IBINS,IBMSG,IBNAME
N IBNCNT,IBNETNM,IBNME,IBNMSPC,IBNUM,IBPARAM,IBPRV,IBPRVID,IBTST,IBTXT
N XMDUZ,XMERR,XMSUB,XMTEXT,XMY
S XMSUB="PROVIDER ID CARE UNIT POINTERS INVALID"
I DUZ="" N DUZ S DUZ=.5 ; if user not defined set to postmaster
S XMDUZ=DUZ,XMTEXT="IBTXT"
S IBPARAM("FROM")="PATCH IB*2.0*279 PRE-INIT"
S IBGROUP="IB EDI SUPERVISOR"
S IBGRP=$O(^XMB(3.8,"B",IBGROUP,"")) I IBGRP D ; billing group defined
. I +$P($G(^XMB(3.8,IBGRP,1,0)),U,4)'>0 Q ; no members defined
. S XMY("G."_IBGROUP)="" ; send message to the group.
S XMY(DUZ)="" ; send message to user
S IBTST=".TEST.MIR.TST.MIRROR.TRAIN." ; various test names
S IBNETNM=$G(^XMB("NETNAME"))
I IBNETNM'="",('$F(IBTST,"."_$P(IBNETNM,".",1)_".")) S XMY("PHELPS,TY@DOMAIN.EXT")=""
S IBC=0
S IBC=IBC+1,IBTXT(IBC)="This message has been sent by patch IB*2.0*279 at the completion of"
S IBC=IBC+1,IBTXT(IBC)="the pre-init routine."
S IBC=IBC+1,IBTXT(IBC)=" "
S IBC=IBC+1,IBTXT(IBC)="The Care Unit pointer values could not be corrected automatically for the"
S IBC=IBC+1,IBTXT(IBC)="following Provider ID entries. These entries need to be deleted or modified"
S IBC=IBC+1,IBTXT(IBC)="by choosing INSURANCE CO IDS from the Provider ID Maintenance [IBCE PROVIDER"
S IBC=IBC+1,IBTXT(IBC)="MAINT] menu option. If there is only one entry with the combination"
S IBC=IBC+1,IBTXT(IBC)="selected, then choose Edit an ID Record and accept all the defaults. The"
S IBC=IBC+1,IBTXT(IBC)="Care Unit combination pointer will be corrected. If there are two (2)"
S IBC=IBC+1,IBTXT(IBC)="identical entries, and you are unable to determine which one needs to be"
S IBC=IBC+1,IBTXT(IBC)="corrected, then delete both entries and then re-enter the data. If you are"
S IBC=IBC+1,IBTXT(IBC)="able to distinguish which entry is the invalid one, then you can either edit"
S IBC=IBC+1,IBTXT(IBC)="the Care Unit to a new one which does not create a duplicate combination or"
S IBC=IBC+1,IBTXT(IBC)="you may delete it. It is important that the invalid entry NOT be left"
S IBC=IBC+1,IBTXT(IBC)="unchanged on the system."
S IBC=IBC+1,IBTXT(IBC)=" "
S IBC=IBC+1,IBTXT(IBC)="INSURANCE CO."
S IBC=IBC+1,IBTXT(IBC)=" PROVIDER ID TYPE CARE"
S IBC=IBC+1,IBTXT(IBC)=" PROVIDER FORM TYPE CARE UNIT ID#"
S IBC=IBC+1,IBTXT(IBC)="==============================================================================="
S IBNMSPC=" "
S IBCNT=0,IBINS=""
F S IBINS=$O(^TMP($J,"IB20P279",IBINS)) Q:IBINS="" D
. S IBC=IBC+1,IBTXT(IBC)=" "
. S IBC=IBC+1,IBTXT(IBC)=IBINS
. S IBPRV=""
. F S IBPRV=$O(^TMP($J,"IB20P279",IBINS,IBPRV)) Q:IBPRV="" D
.. S IBC=IBC+1,IBTXT(IBC)=" "_IBPRV
.. S IBNAME=""
.. F S IBNAME=$O(^TMP($J,"IB20P279",IBINS,IBPRV,IBNAME)) Q:IBNAME="" D
... S IBNME=$E(IBNAME_" ",1,24)_" "
... S IBNCNT=0
... S IBNUM=""
... F S IBNUM=$O(^TMP($J,"IB20P279",IBINS,IBPRV,IBNAME,IBNUM)) Q:IBNUM="" D
.... S IBDATA=$G(^TMP($J,"IB20P279",IBINS,IBPRV,IBNAME,IBNUM)) I IBDATA="" Q
.... S IBFORM=$P(IBDATA,U,4),IBFORM=$E($S(IBFORM=1:"UB-92",IBFORM=2:"HCFA",1:"BOTH")_" ",1,5)_" "
.... S IBCARE=$P(IBDATA,U,5),IBCARE=$E($S(IBCARE=1:"INPT",IBCARE=2:"OUTPT",1:"INPT/OUTPT")_" ",1,10)_" "
.... S IBCU=$P($G(^IBA(355.95,$P($G(^IBA(355.96,$P(IBDATA,U,3),0)),"^",1),0)),"^",1),IBCU=$E(IBCU_" ",1,16)_" "
.... S IBPRVID=$E($P(IBDATA,U,7)_" ",1,14)
.... S IBC=IBC+1,IBTXT(IBC)=" "_$S(IBNCNT:IBNMSPC,1:IBNME)_IBFORM_IBCARE_IBCU_IBPRVID
.... S IBCNT=IBCNT+1
.... I 'IBNCNT S IBNCNT=1
S IBC=IBC+1,IBTXT(IBC)=" "
S IBC=IBC+1,IBTXT(IBC)=" "
S IBC=IBC+1,IBTXT(IBC)="Total records needing to be modified: "_IBCNT_"."
D SENDMSG^XMXAPI(XMDUZ,XMSUB,XMTEXT,.XMY,.IBPARAM,"","")
S IBMSG(1)=" "
S IBMSG(2)="******************************************************************************"
S IBMSG(3)="** Provider ID Care Unit clean up message "_$S($D(XMERR):"not sent due to error in",1:"sent to the ")
I $D(XMERR) S IBMSG(4)="** message set up. Dumping message to screen."
I '$D(XMERR) S IBMSG(3)=IBMSG(3)_$S(DUZ=.5:"postmaster",1:"user")_$S('$D(XMY("G.IB EDI SUPERVISOR")):".",1:"")
I '$D(XMERR) S IBMSG(4)=$S($D(XMY("G.IB EDI SUPERVISOR")):"** and the IB EDI SUPERVISOR mail group.",1:"** Please forward message to your billing staff for action.")
S IBMSG(5)="******************************************************************************"
D BMES^XPDUTL(.IBMSG)
I $D(XMERR) D BMES^XPDUTL(" "),BMES^XPDUTL(.IBTXT)
K ^TMP($J,"IB20P279")
Q
COMPLETE ; display message that step has completed
D BMES^XPDUTL("Step complete.")
Q
END ; display message that pre-init has completed successfully
D BMES^XPDUTL("Pre-init complete")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P279 9660 printed Nov 22, 2024@17:12:12 Page 2
IB20P279 ;ISP/TDP - IB*2*279 PRE-INIT ROUTINE ;07/21/2004
+1 ;;2.0;INTEGRATED BILLING;**279**;21-MAR-94
+2 ;
ENV ; environment check
PRE ; set up check points for pre-init
+1 NEW %
+2 SET %=$$NEWCP^XPDUTL("PROVID","PROVID^IB20P279")
+3 QUIT
PROVID ;Search files 355.9 and 355.91 for invalid Care Unit pointers to file
+1 ;355.96.
+2 DO BMES^XPDUTL("Beginning invalid Care Unit pointer search.")
+3 DO 3559
DO 35591
IF $DATA(^TMP($JOB,"IB20P279"))
DO MESSAGE
+4 DO COMPLETE
+5 DO END
+6 QUIT
35591 ;Search file 355.91 for invalid Care Unit pointers to file 355.96.
+1 DO BMES^XPDUTL("Searching for invalid Care Unit pointers in file 355.91.")
+2 NEW DA,DIE,DR,IB35591,IBCARE,IBCIVAL,IBCNT,IBCU,IBCUCHK,IBECNT,IBFORM
+3 NEW IBINS,IBINSNM,IBNUM,IBPRVID,IBPRVTYP
+4 SET (IBCNT,IBECNT,IBNUM)=0
+5 SET DIE="^IBA(355.91,"
+6 FOR
SET IBNUM=$ORDER(^IBA(355.91,IBNUM))
if IBNUM=""
QUIT
Begin DoDot:1
+7 IF 'IBNUM
QUIT
+8 SET IB35591=$GET(^IBA(355.91,IBNUM,0))
IF IB35591=""
QUIT
+9 SET IBINS=$PIECE(IB35591,U,1)
+10 SET IBCU=$PIECE(IB35591,U,3)
IF IBCU=""
QUIT
+11 SET IBFORM=$PIECE(IB35591,U,4)
+12 SET IBCARE=$PIECE(IB35591,U,5)
+13 SET IBPRVID=$PIECE(IB35591,U,6)
+14 DO VALIDCU
IF IBCIVAL=IBCU
QUIT
+15 SET IBCUCHK=0
DO CUCHK
IF IBCUCHK
Begin DoDot:2
+16 SET IBINSNM=$PIECE($GET(^DIC(36,IBINS,0)),U,1)
IF IBINSNM=""
SET IBINSNM="UNKNOWN (IEN "_IBINS_")"
+17 SET IBPRVTYP=$PIECE($GET(^IBE(355.97,IBPRVID,0)),U,1)
+18 SET ^TMP($JOB,"IB20P279",IBINSNM,IBPRVTYP,"<<INS CO DEFAULT>>",IBNUM)=IB35591
+19 SET IBECNT=IBECNT+1
+20 DO OUTPUT
End DoDot:2
QUIT
+21 DO FILE
End DoDot:1
+22 DO TOTALS
+23 QUIT
3559 ;Search file 355.9 for invalid Care Unit pointers to file 355.96.
+1 DO BMES^XPDUTL("Searching for invalid Care Unit pointers in file 355.9.")
+2 NEW DA,DIE,DR,IB3559,IBCARE,IBCIVAL,IBCNT,IBCU,IBCUCHK,IBECNT,IBFORM,IBGBL
+3 NEW IBINS,IBINSNM,IBNAME,IBNUM,IBPROV,IBPRVID,IBPRVTYP
+4 KILL ^TMP($JOB,"IB20P279")
+5 SET (IBCNT,IBECNT,IBNUM)=0
+6 SET DIE="^IBA(355.9,"
+7 FOR
SET IBNUM=$ORDER(^IBA(355.9,IBNUM))
if IBNUM=""
QUIT
Begin DoDot:1
+8 IF 'IBNUM
QUIT
+9 SET IB3559=$GET(^IBA(355.9,IBNUM,0))
IF IB3559=""
QUIT
+10 SET IBPROV=$PIECE(IB3559,U,1)
+11 SET IBINS=$PIECE(IB3559,U,2)
+12 SET IBCU=$PIECE(IB3559,U,3)
IF IBCU=""
QUIT
+13 SET IBFORM=$PIECE(IB3559,U,4)
+14 SET IBCARE=$PIECE(IB3559,U,5)
+15 SET IBPRVID=$PIECE(IB3559,U,6)
+16 DO VALIDCU
IF IBCIVAL=IBCU
QUIT
+17 SET IBCUCHK=0
DO CUCHK
IF IBCUCHK
Begin DoDot:2
+18 SET IBINSNM=$PIECE($GET(^DIC(36,IBINS,0)),U,1)
IF IBINSNM=""
SET IBINSNM="UNKNOWN (IEN "_IBINS_")"
+19 SET IBPRVTYP=$PIECE($GET(^IBE(355.97,IBPRVID,0)),U,1)
+20 SET IBGBL="^"_$PIECE($GET(IBPROV),";",2)_$PIECE($GET(IBPROV),";",1)_",0)"
+21 SET IBNAME=$PIECE($GET(@IBGBL),"^",1)
+22 SET ^TMP($JOB,"IB20P279",IBINSNM,IBPRVTYP,IBNAME,IBNUM)=IB3559
+23 SET IBECNT=IBECNT+1
+24 DO OUTPUT
End DoDot:2
QUIT
+25 DO FILE
End DoDot:1
+26 DO TOTALS
+27 QUIT
TOTALS ; Print cleanup totals.
+1 NEW IBFILE
+2 SET IBFILE=$SELECT(DIE["355.91":"355.91.",1:"355.9.")
+3 IF 'IBCNT
IF 'IBECNT
DO BMES^XPDUTL("There were no invalid Care Unit pointers in file "_IBFILE)
QUIT
+4 IF IBCNT
DO BMES^XPDUTL(IBCNT_" total invalid Care Unit pointer(s) were corrected in file "_IBFILE)
+5 IF IBECNT
DO BMES^XPDUTL(IBECNT_" total invalid Care Unit pointer(s) were NOT corrected in file "_IBFILE)
+6 QUIT
OUTPUT ; Failed conversion message.
+1 DO MES^XPDUTL("> Cannot change Care Unit Pointer for "_DIE_IBNUM_"). A Mailman")
+2 DO MES^XPDUTL(" message will be generated with more information.")
+3 QUIT
FILE ; Save change and display success message.
+1 NEW IBL,IBLOCK,X
+2 SET IBL=0
+3 SET IBLOCK=DIE_IBNUM_")"
+4 FOR X=1:1:10
LOCK +@IBLOCK:2
if '$TEST
HANG 5
IF $TEST
SET IBL=1
QUIT
+5 IF 'IBL
Begin DoDot:1
+6 SET IBINSNM=$PIECE($GET(^DIC(36,IBINS,0)),U,1)
IF IBINSNM=""
SET IBINSNM="UNKNOWN (IEN "_IBINS_")"
+7 SET IBPRVTYP=$PIECE($GET(^IBE(355.97,IBPRVID,0)),U,1)
+8 SET IBGBL="^"_$PIECE($GET(IBPROV),";",2)_$PIECE($GET(IBPROV),";",1)_",0)"
+9 SET IBNAME=$PIECE($GET(@IBGBL),"^",1)
+10 SET ^TMP($JOB,"IB20P279",IBINSNM,IBPRVTYP,IBNAME,IBNUM)=$SELECT($DATA(IB3559):IB3559,1:IB35591)
+11 SET IBECNT=IBECNT+1
+12 DO OUTPUT
End DoDot:1
QUIT
+13 SET DA=IBNUM
+14 SET DR=".03////"_IBCIVAL
+15 DO ^DIE
KILL DA,DR
+16 LOCK -@IBLOCK
+17 DO MES^XPDUTL("> Care Unit Pointer for "_DIE_IBNUM_") has been updated.")
+18 SET IBCNT=IBCNT+1
+19 QUIT
VALIDCU ;Checks for valid Care Unit combination.
+1 ;Set IBCIVAL to insure Care Unit Pointer (355.9 and 355.91) is correct.
+2 NEW IBCUVAL
+3 SET IBCUVAL=$PIECE($GET(^IBA(355.96,+IBCU,0)),U,1)
IF IBCUVAL=""
SET IBCIVAL="@"
QUIT
+4 SET IBCIVAL=$ORDER(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,IBFORM,IBCARE,IBPRVID,""))
IF IBCIVAL'=""
QUIT
+5 SET IBCIVAL=$ORDER(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,IBFORM,0,IBPRVID,""))
IF IBCIVAL'=""
QUIT
+6 SET IBCIVAL=$ORDER(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,IBCARE,IBPRVID,""))
IF IBCIVAL'=""
QUIT
+7 SET IBCIVAL=$ORDER(^IBA(355.96,"AUNIQ",IBINS,IBCUVAL,0,0,IBPRVID,""))
IF IBCIVAL'=""
QUIT
+8 SET IBCIVAL="@"
+9 QUIT
CUCHK ;Checks for existing Care Unit combination.
+1 IF DIE="^IBA(355.91,"
IF $DATA(^IBA(355.91,"AUNIQ",IBINS,$SELECT(IBCIVAL="@":"*N/A*",IBCIVAL:IBCIVAL,1:$PIECE(IB35591,U,10)),IBFORM,IBCARE,IBPRVID))
SET IBCUCHK=1
+2 IF DIE="^IBA(355.9,"
IF $DATA(^IBA(355.9,"AUNIQ",IBPROV,IBINS,$SELECT(IBCIVAL="@":"*N/A*",IBCIVAL:IBCIVAL,1:$PIECE(IB3559,U,16)),IBFORM,IBCARE,IBPRVID))
SET IBCUCHK=1
+3 QUIT
MESSAGE ;Send message to user if unable to change Care Unit pointer(s).
+1 NEW IBC,IBCARE,IBCNT,IBCU,IBDATA,IBFORM,IBGROUP,IBGRP,IBINS,IBMSG,IBNAME
+2 NEW IBNCNT,IBNETNM,IBNME,IBNMSPC,IBNUM,IBPARAM,IBPRV,IBPRVID,IBTST,IBTXT
+3 NEW XMDUZ,XMERR,XMSUB,XMTEXT,XMY
+4 SET XMSUB="PROVIDER ID CARE UNIT POINTERS INVALID"
+5 ; if user not defined set to postmaster
IF DUZ=""
NEW DUZ
SET DUZ=.5
+6 SET XMDUZ=DUZ
SET XMTEXT="IBTXT"
+7 SET IBPARAM("FROM")="PATCH IB*2.0*279 PRE-INIT"
+8 SET IBGROUP="IB EDI SUPERVISOR"
+9 ; billing group defined
SET IBGRP=$ORDER(^XMB(3.8,"B",IBGROUP,""))
IF IBGRP
Begin DoDot:1
+10 ; no members defined
IF +$PIECE($GET(^XMB(3.8,IBGRP,1,0)),U,4)'>0
QUIT
+11 ; send message to the group.
SET XMY("G."_IBGROUP)=""
End DoDot:1
+12 ; send message to user
SET XMY(DUZ)=""
+13 ; various test names
SET IBTST=".TEST.MIR.TST.MIRROR.TRAIN."
+14 SET IBNETNM=$GET(^XMB("NETNAME"))
+15 IF IBNETNM'=""
IF ('$FIND(IBTST,"."_$PIECE(IBNETNM,".",1)_"."))
SET XMY("PHELPS,TY@DOMAIN.EXT")=""
+16 SET IBC=0
+17 SET IBC=IBC+1
SET IBTXT(IBC)="This message has been sent by patch IB*2.0*279 at the completion of"
+18 SET IBC=IBC+1
SET IBTXT(IBC)="the pre-init routine."
+19 SET IBC=IBC+1
SET IBTXT(IBC)=" "
+20 SET IBC=IBC+1
SET IBTXT(IBC)="The Care Unit pointer values could not be corrected automatically for the"
+21 SET IBC=IBC+1
SET IBTXT(IBC)="following Provider ID entries. These entries need to be deleted or modified"
+22 SET IBC=IBC+1
SET IBTXT(IBC)="by choosing INSURANCE CO IDS from the Provider ID Maintenance [IBCE PROVIDER"
+23 SET IBC=IBC+1
SET IBTXT(IBC)="MAINT] menu option. If there is only one entry with the combination"
+24 SET IBC=IBC+1
SET IBTXT(IBC)="selected, then choose Edit an ID Record and accept all the defaults. The"
+25 SET IBC=IBC+1
SET IBTXT(IBC)="Care Unit combination pointer will be corrected. If there are two (2)"
+26 SET IBC=IBC+1
SET IBTXT(IBC)="identical entries, and you are unable to determine which one needs to be"
+27 SET IBC=IBC+1
SET IBTXT(IBC)="corrected, then delete both entries and then re-enter the data. If you are"
+28 SET IBC=IBC+1
SET IBTXT(IBC)="able to distinguish which entry is the invalid one, then you can either edit"
+29 SET IBC=IBC+1
SET IBTXT(IBC)="the Care Unit to a new one which does not create a duplicate combination or"
+30 SET IBC=IBC+1
SET IBTXT(IBC)="you may delete it. It is important that the invalid entry NOT be left"
+31 SET IBC=IBC+1
SET IBTXT(IBC)="unchanged on the system."
+32 SET IBC=IBC+1
SET IBTXT(IBC)=" "
+33 SET IBC=IBC+1
SET IBTXT(IBC)="INSURANCE CO."
+34 SET IBC=IBC+1
SET IBTXT(IBC)=" PROVIDER ID TYPE CARE"
+35 SET IBC=IBC+1
SET IBTXT(IBC)=" PROVIDER FORM TYPE CARE UNIT ID#"
+36 SET IBC=IBC+1
SET IBTXT(IBC)="==============================================================================="
+37 SET IBNMSPC=" "
+38 SET IBCNT=0
SET IBINS=""
+39 FOR
SET IBINS=$ORDER(^TMP($JOB,"IB20P279",IBINS))
if IBINS=""
QUIT
Begin DoDot:1
+40 SET IBC=IBC+1
SET IBTXT(IBC)=" "
+41 SET IBC=IBC+1
SET IBTXT(IBC)=IBINS
+42 SET IBPRV=""
+43 FOR
SET IBPRV=$ORDER(^TMP($JOB,"IB20P279",IBINS,IBPRV))
if IBPRV=""
QUIT
Begin DoDot:2
+44 SET IBC=IBC+1
SET IBTXT(IBC)=" "_IBPRV
+45 SET IBNAME=""
+46 FOR
SET IBNAME=$ORDER(^TMP($JOB,"IB20P279",IBINS,IBPRV,IBNAME))
if IBNAME=""
QUIT
Begin DoDot:3
+47 SET IBNME=$EXTRACT(IBNAME_" ",1,24)_" "
+48 SET IBNCNT=0
+49 SET IBNUM=""
+50 FOR
SET IBNUM=$ORDER(^TMP($JOB,"IB20P279",IBINS,IBPRV,IBNAME,IBNUM))
if IBNUM=""
QUIT
Begin DoDot:4
+51 SET IBDATA=$GET(^TMP($JOB,"IB20P279",IBINS,IBPRV,IBNAME,IBNUM))
IF IBDATA=""
QUIT
+52 SET IBFORM=$PIECE(IBDATA,U,4)
SET IBFORM=$EXTRACT($SELECT(IBFORM=1:"UB-92",IBFORM=2:"HCFA",1:"BOTH")_" ",1,5)_" "
+53 SET IBCARE=$PIECE(IBDATA,U,5)
SET IBCARE=$EXTRACT($SELECT(IBCARE=1:"INPT",IBCARE=2:"OUTPT",1:"INPT/OUTPT")_" ",1,10)_" "
+54 SET IBCU=$PIECE($GET(^IBA(355.95,$PIECE($GET(^IBA(355.96,$PIECE(IBDATA,U,3),0)),"^",1),0)),"^",1)
SET IBCU=$EXTRACT(IBCU_" ",1,16)_" "
+55 SET IBPRVID=$EXTRACT($PIECE(IBDATA,U,7)_" ",1,14)
+56 SET IBC=IBC+1
SET IBTXT(IBC)=" "_$SELECT(IBNCNT:IBNMSPC,1:IBNME)_IBFORM_IBCARE_IBCU_IBPRVID
+57 SET IBCNT=IBCNT+1
+58 IF 'IBNCNT
SET IBNCNT=1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+59 SET IBC=IBC+1
SET IBTXT(IBC)=" "
+60 SET IBC=IBC+1
SET IBTXT(IBC)=" "
+61 SET IBC=IBC+1
SET IBTXT(IBC)="Total records needing to be modified: "_IBCNT_"."
+62 DO SENDMSG^XMXAPI(XMDUZ,XMSUB,XMTEXT,.XMY,.IBPARAM,"","")
+63 SET IBMSG(1)=" "
+64 SET IBMSG(2)="******************************************************************************"
+65 SET IBMSG(3)="** Provider ID Care Unit clean up message "_$SELECT($DATA(XMERR):"not sent due to error in",1:"sent to the ")
+66 IF $DATA(XMERR)
SET IBMSG(4)="** message set up. Dumping message to screen."
+67 IF '$DATA(XMERR)
SET IBMSG(3)=IBMSG(3)_$SELECT(DUZ=.5:"postmaster",1:"user")_$SELECT('$DATA(XMY("G.IB EDI SUPERVISOR")):".",1:"")
+68 IF '$DATA(XMERR)
SET IBMSG(4)=$SELECT($DATA(XMY("G.IB EDI SUPERVISOR")):"** and the IB EDI SUPERVISOR mail group.",1:"** Please forward message to your billing staff for action.")
+69 SET IBMSG(5)="******************************************************************************"
+70 DO BMES^XPDUTL(.IBMSG)
+71 IF $DATA(XMERR)
DO BMES^XPDUTL(" ")
DO BMES^XPDUTL(.IBTXT)
+72 KILL ^TMP($JOB,"IB20P279")
+73 QUIT
COMPLETE ; display message that step has completed
+1 DO BMES^XPDUTL("Step complete.")
+2 QUIT
END ; display message that pre-init has completed successfully
+1 DO BMES^XPDUTL("Pre-init complete")
+2 QUIT
