- 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 Mar 13, 2025@21:06:52 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
