IBCNSBL1 ;ALB/AAS - NEW INSURANCE POLICY BULLETIN ;29-AUG-93
;;2.0;INTEGRATED BILLING;**6,28,82,249,276,516**;21-MAR-94;Build 123
;;Per VA Directive 6402, this routine should not be modified.
;
BULL ; -- send bulletin
N IBCNT
S XMSUB="New Insurance Policy For "_$E($P(IBP,"^"),1,20)_" Pt. Id: "_$P(IBP,"^",2)
S IBT(1)=" A new insurance policy has been added for:"
S IBT(2)=" Patient: "_$E($P(IBP,"^")_" ",1,25)_" PT. ID: "_$P(IBP,"^",2)
S IBT(3)=""
S IBT(4)=" New Policy: "
S IBCNT=4 D HDR,NPOL
S IBCNT=IBCNT+1,IBT(IBCNT)=""
S IBCNT=IBCNT+1,IBT(IBCNT)=" Previous Policy(s): "
D HDR,OPOL
S IBCNT=IBCNT+1,IBT(IBCNT)=""
S IBCNT=IBCNT+1,IBT(IBCNT)=" Buffer Policy(s): "
D BUFF
S IBCNT=IBCNT+1,IBT(IBCNT)=""
S IBCNT=IBCNT+1,IBT(IBCNT)=" Possible billable Inpt. Care: "
D INPT
S IBCNT=IBCNT+1,IBT(IBCNT)=""
S IBCNT=IBCNT+1,IBT(IBCNT)=" Possible billable Opt. Care: "
D OPT
I $$ECMEBIL^IBNCPDPU(DFN,DT) D
. S IBCNT=IBCNT+1,IBT(IBCNT)=""
. S IBCNT=IBCNT+1,IBT(IBCNT)=" *** NOTE: Prescriptions for this patient are ECME BILLABLE and may be"
. S IBCNT=IBCNT+1,IBT(IBCNT)=" processed using the GENERATE ECME RX BILLS option contained in the"
. S IBCNT=IBCNT+1,IBT(IBCNT)=" Billing Clerk's Menu"
;
S IBCNT=IBCNT+1,IBT(IBCNT)=""
S IBCNT=IBCNT+1,IBT(IBCNT)=" Added by: "_$P($G(^VA(200,+$P(IBEVTA1,"^",2),0)),"^")
S IBCNT=IBCNT+1,IBT(IBCNT)=" on: "_$$DAT1^IBOUTL(+IBEVTA1,"2P")
S IBCNT=IBCNT+1,IBT(IBCNT)=" Option: "
;
I $D(XQY0) S IBT(IBCNT)=IBT(IBCNT)_$P($G(XQY0),"^",2)
I $D(ZTQUEUED),$P($G(XQY0),"^",2)="" S IBT(IBCNT)=IBT(IBCNT)_"Queued Job - "_$G(ZTDESC)
D SEND
BULLQ Q
;
NPOL ; -- set up new policy
S IBCNT=IBCNT+1
S IBT(IBCNT)=$$D1(IBEVTA0)
Q
;
OPOL ; -- set up old policies
N J,X,IBPCNT
S J=0 F S J=$O(^DPT(DFN,.312,J)) Q:'J I J'=IBCDFN S X=$G(^DPT(DFN,.312,J,0)) S IBCNT=IBCNT+1,IBT(IBCNT)=$$D1(X) S IBPCNT=$G(IBPCNT)+1
I $G(IBPCNT)<1 S IBCNT=IBCNT+1,IBT(IBCNT)=" No Previous Policies On file!"
Q
;
SEND S XMDUZ="INTEGRATED BILLING PACKAGE",XMTEXT="IBT("
K XMY S XMN=0
S IBGRP=$P($G(^XMB(3.8,+$P($G(^IBE(350.9,1,4)),"^",4),0)),"^")
I IBGRP]"" S XMY("G."_IBGRP_"@"_^XMB("NETNAME"))=""
D ^XMD
K X,Y,IBI,IBT,IBGRP,XMDUZ,XMTEXT,XMY,XMSUB
Q
;
HDR ; -- print standard header
D HDR1("=",76)
Q
;
HDR1(CHAR,LENG) ; -- print header, specify character
S IBCNT=IBCNT+1
S IBT(IBCNT)=" Insurance Co. Subscriber ID Group Holder Effective Expires"
S IBCNT=IBCNT+1,X="",$P(X,CHAR,LENG)=""
S IBT(IBCNT)=X
Q
;
;
D1(IBINS) N X,IBX
S IBX="" I '$G(IBINS) G DQ
S IBX=" "_$E($S($D(^DIC(36,+IBINS,0)):$E($P(^(0),"^",1),1,16),1:"UNKNOWN")_" ",1,16)_" "
S IBX=IBX_$E($P(IBINS,"^",2)_" ",1,16)_" "
S IBX=IBX_$E($$GRP^IBCNS($P(IBINS,"^",18))_" ",1,10)_" "
S X=$P(IBINS,"^",6) S IBX=IBX_$E($S(X="v":"SELF",X="s":"SPOUSE",1:"OTHER")_" ",1,8)
S IBX=IBX_$E($$DAT1^IBOUTL($P(IBINS,"^",8))_" ",1,10)_$$DAT1^IBOUTL($P(IBINS,"^",4))
DQ Q IBX
;
OPT ; -- list opt treatment (sched appoints only)
N CNT S CNT=0
;
I $D(^TMP($J,"SDAMA201","GETAPPT","ERROR")) S IBCNT=IBCNT+1,IBT(IBCNT)=" Unable to look-up Scheduled Appointments." D Q
. F S CNT=$O(^TMP($J,"SDAMA201","GETAPPT","ERROR",CNT)) Q:'CNT S IBCNT=IBCNT+1,IBT(IBCNT)=" "_$G(^TMP($J,"SDAMA201","GETAPPT","ERROR",CNT))
;
S OPT=0 F S OPT=$O(^TMP($J,"SDAMA201","GETAPPT",OPT)) Q:'OPT D
.S IBCNT=IBCNT+1
.I IBCNT>100 S IBT(IBCNT)="Too many to list" S OPT=9999999 Q
.S IBT(IBCNT)=" Outpatient Visit on "_$$DAT1^IBOUTL($G(^TMP($J,"SDAMA201","GETAPPT",OPT,1)))_" to "_$P($G(^TMP($J,"SDAMA201","GETAPPT",OPT,2)),"^",2)
.S CNT=CNT+1
I 'CNT S IBCNT=IBCNT+1,IBT(IBCNT)=" No Scheduled appointments found."
Q
;
INPT ; -- list inpt. treatment (admissions only)
N CNT S CNT=0
I $G(^DPT(DFN,.1))]"" S CNT=CNT+1,IBCNT=IBCNT+1,IBT(IBCNT)=" Currently an Inpatient on "_$G(^DPT(DFN,.1))
I $G(IBTADD) S IBCNT=IBCNT+1,IBT(IBCNT)=" Entry Added to Claims Tracking for Current Admission."
I $G(VAIN(1)) S CNT=CNT+1,IBCNT=IBCNT+1,IBT(IBCNT)=" Previously an inpatient on ward "_$P(VAIN(4),"^",2)_" on "_$$DAT1^IBOUTL($P(START,"."))
S INPT=START F S INPT=$O(^DGPM("APTT1",DFN,INPT)) Q:'INPT!(INPT>END) S DGPM=0 F S DGPM=$O(^DGPM("APTT1",DFN,INPT,DGPM)) Q:'DGPM D
.Q:'$G(^DGPM(DGPM,0))
.S IBCNT=IBCNT+1
.S IBT(IBCNT)=" Inpatient Admission on "_$$DAT1^IBOUTL(+^DGPM(DGPM,0),"2P")
.S CNT=CNT+1
I 'CNT S IBCNT=IBCNT+1,IBT(IBCNT)=" No Admissions found."
Q
;
BUFF ; -- list insurance buffer entries for the patient
N IBBDA,IBX,IBY,IBB40,IBB60
I '$$BUFFER^IBCNBU1(DFN) S IBCNT=IBCNT+1,IBT(IBCNT)=" No Insurance Buffer entries for this Patient." Q
;
S IBBDA=0 F S IBBDA=$O(^IBA(355.33,"C",DFN,IBBDA)) Q:'IBBDA D
. S IBB40=$G(^IBA(355.33,IBBDA,40)),IBB60=$G(^IBA(355.33,IBBDA,60))
. ;IB*2.0*516/BAA - Use HIPAA compliant fields.
. S $P(IBB40,U,2)=$$GET1^DIQ(355.33,IBBDA,90.01) ;516 - baa - new group name field
. S $P(IBB40,U,3)=$$GET1^DIQ(355.33,IBBDA,90.02) ;516 - baa - new group number field
. S $P(IBB60,U,4)=$$GET1^DIQ(355.33,IBBDA,90.03) ;516 - baa - new subscriber id field
. ;
. S IBY=$P($G(^IBA(355.33,+IBBDA,20)),U,1),IBX=" "_$E($S(IBY'="":IBY,1:"UNKNOWN")_" ",1,16)_" "
. S IBX=IBX_$E($P(IBB60,"^",4)_" ",1,16)_" "
. S IBX=IBX_$E($S($P(IBB40,U,3)'="":$P(IBB40,U,3),$P(IBB40,U,2)'="":$P(IBB40,U,2),$P(IBB40,U,1)=0:"Ind. Plan",1:"")_" ",1,10)_" "
. S IBY=$P(IBB60,"^",5) S IBX=IBX_$E($S(IBY="v":"SELF",IBY="s":"SPOUSE",1:"OTHER")_" ",1,8)
. S IBX=IBX_$E($$DAT1^IBOUTL($P(IBB60,"^",2))_" ",1,10)_$$DAT1^IBOUTL($P(IBB60,"^",3))
. S IBCNT=IBCNT+1,IBT(IBCNT)=IBX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSBL1 5793 printed Dec 13, 2024@02:16:51 Page 2
IBCNSBL1 ;ALB/AAS - NEW INSURANCE POLICY BULLETIN ;29-AUG-93
+1 ;;2.0;INTEGRATED BILLING;**6,28,82,249,276,516**;21-MAR-94;Build 123
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
BULL ; -- send bulletin
+1 NEW IBCNT
+2 SET XMSUB="New Insurance Policy For "_$EXTRACT($PIECE(IBP,"^"),1,20)_" Pt. Id: "_$PIECE(IBP,"^",2)
+3 SET IBT(1)=" A new insurance policy has been added for:"
+4 SET IBT(2)=" Patient: "_$EXTRACT($PIECE(IBP,"^")_" ",1,25)_" PT. ID: "_$PIECE(IBP,"^",2)
+5 SET IBT(3)=""
+6 SET IBT(4)=" New Policy: "
+7 SET IBCNT=4
DO HDR
DO NPOL
+8 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=""
+9 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" Previous Policy(s): "
+10 DO HDR
DO OPOL
+11 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=""
+12 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" Buffer Policy(s): "
+13 DO BUFF
+14 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=""
+15 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" Possible billable Inpt. Care: "
+16 DO INPT
+17 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=""
+18 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" Possible billable Opt. Care: "
+19 DO OPT
+20 IF $$ECMEBIL^IBNCPDPU(DFN,DT)
Begin DoDot:1
+21 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=""
+22 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" *** NOTE: Prescriptions for this patient are ECME BILLABLE and may be"
+23 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" processed using the GENERATE ECME RX BILLS option contained in the"
+24 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" Billing Clerk's Menu"
End DoDot:1
+25 ;
+26 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=""
+27 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" Added by: "_$PIECE($GET(^VA(200,+$PIECE(IBEVTA1,"^",2),0)),"^")
+28 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" on: "_$$DAT1^IBOUTL(+IBEVTA1,"2P")
+29 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" Option: "
+30 ;
+31 IF $DATA(XQY0)
SET IBT(IBCNT)=IBT(IBCNT)_$PIECE($GET(XQY0),"^",2)
+32 IF $DATA(ZTQUEUED)
IF $PIECE($GET(XQY0),"^",2)=""
SET IBT(IBCNT)=IBT(IBCNT)_"Queued Job - "_$GET(ZTDESC)
+33 DO SEND
BULLQ QUIT
+1 ;
NPOL ; -- set up new policy
+1 SET IBCNT=IBCNT+1
+2 SET IBT(IBCNT)=$$D1(IBEVTA0)
+3 QUIT
+4 ;
OPOL ; -- set up old policies
+1 NEW J,X,IBPCNT
+2 SET J=0
FOR
SET J=$ORDER(^DPT(DFN,.312,J))
if 'J
QUIT
IF J'=IBCDFN
SET X=$GET(^DPT(DFN,.312,J,0))
SET IBCNT=IBCNT+1
SET IBT(IBCNT)=$$D1(X)
SET IBPCNT=$GET(IBPCNT)+1
+3 IF $GET(IBPCNT)<1
SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" No Previous Policies On file!"
+4 QUIT
+5 ;
SEND SET XMDUZ="INTEGRATED BILLING PACKAGE"
SET XMTEXT="IBT("
+1 KILL XMY
SET XMN=0
+2 SET IBGRP=$PIECE($GET(^XMB(3.8,+$PIECE($GET(^IBE(350.9,1,4)),"^",4),0)),"^")
+3 IF IBGRP]""
SET XMY("G."_IBGRP_"@"_^XMB("NETNAME"))=""
+4 DO ^XMD
+5 KILL X,Y,IBI,IBT,IBGRP,XMDUZ,XMTEXT,XMY,XMSUB
+6 QUIT
+7 ;
HDR ; -- print standard header
+1 DO HDR1("=",76)
+2 QUIT
+3 ;
HDR1(CHAR,LENG) ; -- print header, specify character
+1 SET IBCNT=IBCNT+1
+2 SET IBT(IBCNT)=" Insurance Co. Subscriber ID Group Holder Effective Expires"
+3 SET IBCNT=IBCNT+1
SET X=""
SET $PIECE(X,CHAR,LENG)=""
+4 SET IBT(IBCNT)=X
+5 QUIT
+6 ;
+7 ;
D1(IBINS) NEW X,IBX
+1 SET IBX=""
IF '$GET(IBINS)
GOTO DQ
+2 SET IBX=" "_$EXTRACT($SELECT($DATA(^DIC(36,+IBINS,0)):$EXTRACT($PIECE(^(0),"^",1),1,16),1:"UNKNOWN")_" ",1,16)_" "
+3 SET IBX=IBX_$EXTRACT($PIECE(IBINS,"^",2)_" ",1,16)_" "
+4 SET IBX=IBX_$EXTRACT($$GRP^IBCNS($PIECE(IBINS,"^",18))_" ",1,10)_" "
+5 SET X=$PIECE(IBINS,"^",6)
SET IBX=IBX_$EXTRACT($SELECT(X="v":"SELF",X="s":"SPOUSE",1:"OTHER")_" ",1,8)
+6 SET IBX=IBX_$EXTRACT($$DAT1^IBOUTL($PIECE(IBINS,"^",8))_" ",1,10)_$$DAT1^IBOUTL($PIECE(IBINS,"^",4))
DQ QUIT IBX
+1 ;
OPT ; -- list opt treatment (sched appoints only)
+1 NEW CNT
SET CNT=0
+2 ;
+3 IF $DATA(^TMP($JOB,"SDAMA201","GETAPPT","ERROR"))
SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" Unable to look-up Scheduled Appointments."
Begin DoDot:1
+4 FOR
SET CNT=$ORDER(^TMP($JOB,"SDAMA201","GETAPPT","ERROR",CNT))
if 'CNT
QUIT
SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" "_$GET(^TMP($JOB,"SDAMA201","GETAPPT","ERROR",CNT))
End DoDot:1
QUIT
+5 ;
+6 SET OPT=0
FOR
SET OPT=$ORDER(^TMP($JOB,"SDAMA201","GETAPPT",OPT))
if 'OPT
QUIT
Begin DoDot:1
+7 SET IBCNT=IBCNT+1
+8 IF IBCNT>100
SET IBT(IBCNT)="Too many to list"
SET OPT=9999999
QUIT
+9 SET IBT(IBCNT)=" Outpatient Visit on "_$$DAT1^IBOUTL($GET(^TMP($JOB,"SDAMA201","GETAPPT",OPT,1)))_" to "_$PIECE($GET(^TMP($JOB,"SDAMA201","GETAPPT",OPT,2)),"^",2)
+10 SET CNT=CNT+1
End DoDot:1
+11 IF 'CNT
SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" No Scheduled appointments found."
+12 QUIT
+13 ;
INPT ; -- list inpt. treatment (admissions only)
+1 NEW CNT
SET CNT=0
+2 IF $GET(^DPT(DFN,.1))]""
SET CNT=CNT+1
SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" Currently an Inpatient on "_$GET(^DPT(DFN,.1))
+3 IF $GET(IBTADD)
SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" Entry Added to Claims Tracking for Current Admission."
+4 IF $GET(VAIN(1))
SET CNT=CNT+1
SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" Previously an inpatient on ward "_$PIECE(VAIN(4),"^",2)_" on "_$$DAT1^IBOUTL($PIECE(START,"."))
+5 SET INPT=START
FOR
SET INPT=$ORDER(^DGPM("APTT1",DFN,INPT))
if 'INPT!(INPT>END)
QUIT
SET DGPM=0
FOR
SET DGPM=$ORDER(^DGPM("APTT1",DFN,INPT,DGPM))
if 'DGPM
QUIT
Begin DoDot:1
+6 if '$GET(^DGPM(DGPM,0))
QUIT
+7 SET IBCNT=IBCNT+1
+8 SET IBT(IBCNT)=" Inpatient Admission on "_$$DAT1^IBOUTL(+^DGPM(DGPM,0),"2P")
+9 SET CNT=CNT+1
End DoDot:1
+10 IF 'CNT
SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" No Admissions found."
+11 QUIT
+12 ;
BUFF ; -- list insurance buffer entries for the patient
+1 NEW IBBDA,IBX,IBY,IBB40,IBB60
+2 IF '$$BUFFER^IBCNBU1(DFN)
SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" No Insurance Buffer entries for this Patient."
QUIT
+3 ;
+4 SET IBBDA=0
FOR
SET IBBDA=$ORDER(^IBA(355.33,"C",DFN,IBBDA))
if 'IBBDA
QUIT
Begin DoDot:1
+5 SET IBB40=$GET(^IBA(355.33,IBBDA,40))
SET IBB60=$GET(^IBA(355.33,IBBDA,60))
+6 ;IB*2.0*516/BAA - Use HIPAA compliant fields.
+7 ;516 - baa - new group name field
SET $PIECE(IBB40,U,2)=$$GET1^DIQ(355.33,IBBDA,90.01)
+8 ;516 - baa - new group number field
SET $PIECE(IBB40,U,3)=$$GET1^DIQ(355.33,IBBDA,90.02)
+9 ;516 - baa - new subscriber id field
SET $PIECE(IBB60,U,4)=$$GET1^DIQ(355.33,IBBDA,90.03)
+10 ;
+11 SET IBY=$PIECE($GET(^IBA(355.33,+IBBDA,20)),U,1)
SET IBX=" "_$EXTRACT($SELECT(IBY'="":IBY,1:"UNKNOWN")_" ",1,16)_" "
+12 SET IBX=IBX_$EXTRACT($PIECE(IBB60,"^",4)_" ",1,16)_" "
+13 SET IBX=IBX_$EXTRACT($SELECT($PIECE(IBB40,U,3)'="":$PIECE(IBB40,U,3),$PIECE(IBB40,U,2)'="":$PIECE(IBB40,U,2),$PIECE(IBB40,U,1)=0:"Ind. Plan",1:"")_" ",1,10)_" "
+14 SET IBY=$PIECE(IBB60,"^",5)
SET IBX=IBX_$EXTRACT($SELECT(IBY="v":"SELF",IBY="s":"SPOUSE",1:"OTHER")_" ",1,8)
+15 SET IBX=IBX_$EXTRACT($$DAT1^IBOUTL($PIECE(IBB60,"^",2))_" ",1,10)_$$DAT1^IBOUTL($PIECE(IBB60,"^",3))
+16 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=IBX
End DoDot:1
+17 QUIT
