IBCNSBL1 ;ALB/AAS - NEW INSURANCE POLICY BULLETIN ; 29-AUG-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
BULL ; -- send bulletin
;
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)=" Possible billable Inpt. Care: "
D INPT
S IBCNT=IBCNT+1,IBT(IBCNT)=""
S IBCNT=IBCNT+1,IBT(IBCNT)=" Possible billable Opt. Care: "
D OPT
S IBCNT=IBCNT+1,IBT(IBCNT)=""
S IBCNT=IBCNT+1,IBT(IBCNT)=" Added by: "_$P($G(^VA(200,+$P(IBEVT1,"^",2),0)),"^")
S IBCNT=IBCNT+1,IBT(IBCNT)=" on: "_$$DAT1^IBOUTL(+IBEVT1,"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(IBEVTA)
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
S OPT=START
F S OPT=$O(^DPT(DFN,"S",OPT)) Q:'OPT!(OPT>END) D
.S IBCNT=IBCNT+1
.Q:$P(^DPT(DFN,"S",OPT,0),"^",2)]"" ; can't be canceled, inpatient, etc
.S IBT(IBCNT)=" Outpatient Visit on "_$$DAT1^IBOUTL(OPT,"2P")_" to "_$P($G(^SC(+$G(^DPT(DFN,"S",OPT,0)),0)),"^")
.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
IBCNSBL1 ;ALB/AAS - NEW INSURANCE POLICY BULLETIN ; 29-AUG-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
BULL ; -- send bulletin
+1 ;
+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)=" Possible billable Inpt. Care: "
+13 DO INPT
+14 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=""
+15 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" Possible billable Opt. Care: "
+16 DO OPT
+17 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=""
+18 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" Added by: "_$PIECE($GET(^VA(200,+$PIECE(IBEVT1,"^",2),0)),"^")
+19 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" on: "_$$DAT1^IBOUTL(+IBEVT1,"2P")
+20 SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" Option: "
+21 IF $DATA(XQY0)
SET IBT(IBCNT)=IBT(IBCNT)_$PIECE($GET(XQY0),"^",2)
+22 IF $DATA(ZTQUEUED)
IF $PIECE($GET(XQY0),"^",2)=""
SET IBT(IBCNT)=IBT(IBCNT)_"Queued Job - "_$GET(ZTDESC)
+23 DO SEND
BULLQ QUIT
+1 ;
NPOL ; -- set up new policy
+1 SET IBCNT=IBCNT+1
+2 SET IBT(IBCNT)=$$D1(IBEVTA)
+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 SET OPT=START
+3 FOR
SET OPT=$ORDER(^DPT(DFN,"S",OPT))
IF 'OPT!(OPT>END)
QUIT
Begin DoDot:1
+4 SET IBCNT=IBCNT+1
+5 ; can't be canceled, inpatient, etc
IF $PIECE(^DPT(DFN,"S",OPT,0),"^",2)]""
QUIT
+6 SET IBT(IBCNT)=" Outpatient Visit on "_$$DAT1^IBOUTL(OPT,"2P")_" to "_$PIECE($GET(^SC(+$GET(^DPT(DFN,"S",OPT,0)),0)),"^")
+7 SET CNT=CNT+1
End DoDot:1
+8 IF 'CNT
SET IBCNT=IBCNT+1
SET IBT(IBCNT)=" No Scheduled appointments found."
+9 QUIT
+10 ;
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
