IBCNSCD2 ;ALB/CPM - DELETE INSURANCE COMPANY (CON'T) ; 03-FEB-95
;;2.0;INTEGRATED BILLING;**28,46,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
MAIL ; Send results out.
S XMSUB="Insurance Company Deletion Clean-up Completion"
S XMDUZ="INTEGRATED BILLING PACKAGE",XMTEXT="^TMP($J,""IBT"",",XMY(DUZ)=""
;
K ^TMP($J,"IBT") S IBC=0
D SET("The final clean-up for deleted Insurance Company(s) has completed.")
D SET(" ")
S Y=IBBDT D D^DIQ D SET("Job Start Time: "_Y)
S Y=IBEDT D D^DIQ D SET(" Job End Time: "_Y)
;
D SET(" ")
D SET("DELETED COMPANY"_$J("",24)_"REPOINTED TO")
D SET($TR($J("",79)," ","="))
S IBX=0 F S IBX=$O(^TMP($J,"IBCNSCD",IBX)) Q:'IBX S IBX1=+$G(^(IBX)) D
.S X=$E($P($G(^DIC(36,IBX,0)),"^")_" (#"_IBX_")"_$J("",39),1,39)
.S X=X_$S(IBX1:$P($G(^DIC(36,IBX1,0)),"^")_" (#"_IBX1_")",1:"not repointed")
.D SET(X)
;
D SET(" ")
D SET(" ")
D SET("1. Correction of the Disposition (sub-file #2.101) field")
D SET(" 'INJURING PARTIES INSURANCE' (#25)")
D SET(" Number of Disposition records updated: "_+$G(IBCT("DIS")))
I $O(IBCT("DIS",0)) D
.D SET($J("",8)_"The following dispositions had this field deleted and not merged:")
.S DFN=0 F S DFN=$O(IBCT("DIS",DFN)) Q:'DFN D
..S IBNAM=$$PT^IBEFUNC(DFN),IBH=0
..S IBX=$J("",10)_$E($P(IBNAM,"^"),1,25)_" ("_$P(IBNAM,"^",3)_")"
..S IBDAT="" F S IBDAT=$O(IBCT("DIS",DFN,IBDAT)) Q:IBDAT="" D
...S IBDAT1="Date/Time: "_$$DAT2^IBOUTL(9999999-IBDAT)
...I 'IBH D SET($E(IBX_$J("",45),1,45)_IBDAT1)
...E D SET($J("",45)_IBDAT1)
...S IBH=1
;
; - insurance companies
S IBINS(0)="REPOINT PATIENTS TO^.16"
S IBINS(.12)="CLAIMS (INPT) COMPANY NAME^.127"
S IBINS(.13)="PRECERT COMPANY NAME^.139"
S IBINS(.14)="APPEALS COMPANY NAME^.147"
S IBINS(.16)="CLAIMS (OPT) COMPANY NAME^.167"
S IBINS(.18)="CLAIMS (RX) COMPANY NAME^.187"
;JWS;IB*2.0*592;add Dental Ins address
S IBINS(.19)="CLAIMS (DENTAL) COMPANY NAME^.197"
D SET(" ")
D SET("2. Correction of other Insurance Company (file #36) records:")
S IBX="" F S IBX=$O(IBINS(IBX)) Q:IBX="" S IBS=IBINS(IBX) D
.D SET(" Number of records with '"_$P(IBS,"^")_"' (#"_$P(IBS,"^",2)_") updated: "_+$G(IBCT("INS",IBX)))
.I $O(IBCT("INS",IBX,0)) D
..D SET($J("",8)_"The following companies had this field deleted and not merged:")
..S IBCO=0 F S IBCO=$O(IBCT("INS",IBX,IBCO)) Q:'IBCO D
...D SET($J("",10)_$P($G(^DIC(36,IBCO,0)),"^")_" (ien "_IBCO_")")
;
; - insurance reviews
D SET(" ")
D SET("3. Correction of the Insurance Review (file #356.2) field")
D SET(" 'INSURANCE COMPANY CONTACTED' (#.08)")
D SET(" Number of Insurance Review records updated: "_+$G(IBCT("IR")))
I $O(IBCT("IR",0)) D
.D SET($J("",8)_"The following Insurance reviews had this field deleted and not merged:")
.S DFN=0 F S DFN=$O(IBCT("IR",DFN)) Q:'DFN D
..S IBNAM=$$PT^IBEFUNC(DFN),IBH=0
..S IBX=$J("",10)_$E($P(IBNAM,"^"),1,25)_" ("_$P(IBNAM,"^",3)_")"
..S IBDAT="" F S IBDAT=$O(IBCT("IR",DFN,IBDAT)) Q:IBDAT="" D
...S IBDAT1="Review Date/Time: "_$$DAT2^IBOUTL(IBDAT)
...I 'IBH D SET($E(IBX_$J("",45),1,45)_IBDAT1)
...E D SET($J("",45)_IBDAT1)
...S IBH=1
;
; - bills
K IBINS
S IBINS(1)="PRIMARY INSURANCE CARRIER^101"
S IBINS(2)="SECONDARY INSURANCE CARRIER^102"
S IBINS(3)="TERTIARY INSURANCE CARRIER^103"
D SET(" ")
D SET("4. Correction of Bill/Claims (file #399) records:")
S IBX="" F S IBX=$O(IBINS(IBX)) Q:IBX="" S IBS=IBINS(IBX) D
.D SET(" Number of records with '"_$P(IBS,"^")_"' (#"_$P(IBS,"^",2)_") updated: "_+$G(IBCT("BL",IBX)))
.I $O(IBCT("BL",IBX,0)) D
..D SET($J("",8)_"The following bills had this field deleted and not merged:")
..S IBCO=0 F S IBCO=$O(IBCT("BL",IBX,IBCO)) Q:'IBCO D
...S IBS=$G(^DGCR(399,IBCO,0))
...S IBNAM=$$PT^IBEFUNC(+$P(IBS,"^",2))
...D SET($J("",10)_$E($E($P(IBNAM,"^"),1,25)_" ("_$P(IBNAM,"^",3)_")"_$J("",35),1,35)_"Bill #: "_$P(IBS,"^"))
;
; - receivables in AR
D SET(" ")
D SET("5. Number of updated secondary and tertiary carriers of AR receivables: "_+$G(IBCTAR))
;
D ^XMD
K ^TMP($J,"IBT")
Q
;
SET(X) ; Set Message Text Array
S IBC=IBC+1,^TMP($J,"IBT",IBC)=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSCD2 4238 printed Oct 16, 2024@18:17:43 Page 2
IBCNSCD2 ;ALB/CPM - DELETE INSURANCE COMPANY (CON'T) ; 03-FEB-95
+1 ;;2.0;INTEGRATED BILLING;**28,46,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
MAIL ; Send results out.
+1 SET XMSUB="Insurance Company Deletion Clean-up Completion"
+2 SET XMDUZ="INTEGRATED BILLING PACKAGE"
SET XMTEXT="^TMP($J,""IBT"","
SET XMY(DUZ)=""
+3 ;
+4 KILL ^TMP($JOB,"IBT")
SET IBC=0
+5 DO SET("The final clean-up for deleted Insurance Company(s) has completed.")
+6 DO SET(" ")
+7 SET Y=IBBDT
DO D^DIQ
DO SET("Job Start Time: "_Y)
+8 SET Y=IBEDT
DO D^DIQ
DO SET(" Job End Time: "_Y)
+9 ;
+10 DO SET(" ")
+11 DO SET("DELETED COMPANY"_$JUSTIFY("",24)_"REPOINTED TO")
+12 DO SET($TRANSLATE($JUSTIFY("",79)," ","="))
+13 SET IBX=0
FOR
SET IBX=$ORDER(^TMP($JOB,"IBCNSCD",IBX))
if 'IBX
QUIT
SET IBX1=+$GET(^(IBX))
Begin DoDot:1
+14 SET X=$EXTRACT($PIECE($GET(^DIC(36,IBX,0)),"^")_" (#"_IBX_")"_$JUSTIFY("",39),1,39)
+15 SET X=X_$SELECT(IBX1:$PIECE($GET(^DIC(36,IBX1,0)),"^")_" (#"_IBX1_")",1:"not repointed")
+16 DO SET(X)
End DoDot:1
+17 ;
+18 DO SET(" ")
+19 DO SET(" ")
+20 DO SET("1. Correction of the Disposition (sub-file #2.101) field")
+21 DO SET(" 'INJURING PARTIES INSURANCE' (#25)")
+22 DO SET(" Number of Disposition records updated: "_+$GET(IBCT("DIS")))
+23 IF $ORDER(IBCT("DIS",0))
Begin DoDot:1
+24 DO SET($JUSTIFY("",8)_"The following dispositions had this field deleted and not merged:")
+25 SET DFN=0
FOR
SET DFN=$ORDER(IBCT("DIS",DFN))
if 'DFN
QUIT
Begin DoDot:2
+26 SET IBNAM=$$PT^IBEFUNC(DFN)
SET IBH=0
+27 SET IBX=$JUSTIFY("",10)_$EXTRACT($PIECE(IBNAM,"^"),1,25)_" ("_$PIECE(IBNAM,"^",3)_")"
+28 SET IBDAT=""
FOR
SET IBDAT=$ORDER(IBCT("DIS",DFN,IBDAT))
if IBDAT=""
QUIT
Begin DoDot:3
+29 SET IBDAT1="Date/Time: "_$$DAT2^IBOUTL(9999999-IBDAT)
+30 IF 'IBH
DO SET($EXTRACT(IBX_$JUSTIFY("",45),1,45)_IBDAT1)
+31 IF '$TEST
DO SET($JUSTIFY("",45)_IBDAT1)
+32 SET IBH=1
End DoDot:3
End DoDot:2
End DoDot:1
+33 ;
+34 ; - insurance companies
+35 SET IBINS(0)="REPOINT PATIENTS TO^.16"
+36 SET IBINS(.12)="CLAIMS (INPT) COMPANY NAME^.127"
+37 SET IBINS(.13)="PRECERT COMPANY NAME^.139"
+38 SET IBINS(.14)="APPEALS COMPANY NAME^.147"
+39 SET IBINS(.16)="CLAIMS (OPT) COMPANY NAME^.167"
+40 SET IBINS(.18)="CLAIMS (RX) COMPANY NAME^.187"
+41 ;JWS;IB*2.0*592;add Dental Ins address
+42 SET IBINS(.19)="CLAIMS (DENTAL) COMPANY NAME^.197"
+43 DO SET(" ")
+44 DO SET("2. Correction of other Insurance Company (file #36) records:")
+45 SET IBX=""
FOR
SET IBX=$ORDER(IBINS(IBX))
if IBX=""
QUIT
SET IBS=IBINS(IBX)
Begin DoDot:1
+46 DO SET(" Number of records with '"_$PIECE(IBS,"^")_"' (#"_$PIECE(IBS,"^",2)_") updated: "_+$GET(IBCT("INS",IBX)))
+47 IF $ORDER(IBCT("INS",IBX,0))
Begin DoDot:2
+48 DO SET($JUSTIFY("",8)_"The following companies had this field deleted and not merged:")
+49 SET IBCO=0
FOR
SET IBCO=$ORDER(IBCT("INS",IBX,IBCO))
if 'IBCO
QUIT
Begin DoDot:3
+50 DO SET($JUSTIFY("",10)_$PIECE($GET(^DIC(36,IBCO,0)),"^")_" (ien "_IBCO_")")
End DoDot:3
End DoDot:2
End DoDot:1
+51 ;
+52 ; - insurance reviews
+53 DO SET(" ")
+54 DO SET("3. Correction of the Insurance Review (file #356.2) field")
+55 DO SET(" 'INSURANCE COMPANY CONTACTED' (#.08)")
+56 DO SET(" Number of Insurance Review records updated: "_+$GET(IBCT("IR")))
+57 IF $ORDER(IBCT("IR",0))
Begin DoDot:1
+58 DO SET($JUSTIFY("",8)_"The following Insurance reviews had this field deleted and not merged:")
+59 SET DFN=0
FOR
SET DFN=$ORDER(IBCT("IR",DFN))
if 'DFN
QUIT
Begin DoDot:2
+60 SET IBNAM=$$PT^IBEFUNC(DFN)
SET IBH=0
+61 SET IBX=$JUSTIFY("",10)_$EXTRACT($PIECE(IBNAM,"^"),1,25)_" ("_$PIECE(IBNAM,"^",3)_")"
+62 SET IBDAT=""
FOR
SET IBDAT=$ORDER(IBCT("IR",DFN,IBDAT))
if IBDAT=""
QUIT
Begin DoDot:3
+63 SET IBDAT1="Review Date/Time: "_$$DAT2^IBOUTL(IBDAT)
+64 IF 'IBH
DO SET($EXTRACT(IBX_$JUSTIFY("",45),1,45)_IBDAT1)
+65 IF '$TEST
DO SET($JUSTIFY("",45)_IBDAT1)
+66 SET IBH=1
End DoDot:3
End DoDot:2
End DoDot:1
+67 ;
+68 ; - bills
+69 KILL IBINS
+70 SET IBINS(1)="PRIMARY INSURANCE CARRIER^101"
+71 SET IBINS(2)="SECONDARY INSURANCE CARRIER^102"
+72 SET IBINS(3)="TERTIARY INSURANCE CARRIER^103"
+73 DO SET(" ")
+74 DO SET("4. Correction of Bill/Claims (file #399) records:")
+75 SET IBX=""
FOR
SET IBX=$ORDER(IBINS(IBX))
if IBX=""
QUIT
SET IBS=IBINS(IBX)
Begin DoDot:1
+76 DO SET(" Number of records with '"_$PIECE(IBS,"^")_"' (#"_$PIECE(IBS,"^",2)_") updated: "_+$GET(IBCT("BL",IBX)))
+77 IF $ORDER(IBCT("BL",IBX,0))
Begin DoDot:2
+78 DO SET($JUSTIFY("",8)_"The following bills had this field deleted and not merged:")
+79 SET IBCO=0
FOR
SET IBCO=$ORDER(IBCT("BL",IBX,IBCO))
if 'IBCO
QUIT
Begin DoDot:3
+80 SET IBS=$GET(^DGCR(399,IBCO,0))
+81 SET IBNAM=$$PT^IBEFUNC(+$PIECE(IBS,"^",2))
+82 DO SET($JUSTIFY("",10)_$EXTRACT($EXTRACT($PIECE(IBNAM,"^"),1,25)_" ("_$PIECE(IBNAM,"^",3)_")"_$JUSTIFY("",35),1,35)_"Bill #: "_$PIECE(IBS,"^"))
End DoDot:3
End DoDot:2
End DoDot:1
+83 ;
+84 ; - receivables in AR
+85 DO SET(" ")
+86 DO SET("5. Number of updated secondary and tertiary carriers of AR receivables: "_+$GET(IBCTAR))
+87 ;
+88 DO ^XMD
+89 KILL ^TMP($JOB,"IBT")
+90 QUIT
+91 ;
SET(X) ; Set Message Text Array
+1 SET IBC=IBC+1
SET ^TMP($JOB,"IBT",IBC)=X
+2 QUIT
