- IBRBUL ;ALB/CJM - CAT C HOLD CHARGE BULLETIN ; 02-MAR-92
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ; This bulletin is sent even if the local site has chosen
- ; not to hold Cat C charges. In that case, IBHOLDP should be set = 0.
- ; requires: IBDD() = internal node in patient file of valid ins.
- ; DUZ
- ; X = 0 node of IB BILLING ACTION
- ; IBHOLDP = 1 if charge on hold, = 0 otherwise
- ; IBSEQNO = 1 if the charges are new, 3 if updated
- BULL N IBT,IBC,XMSUB,XMY,XMDUZ,XMTEXT,IBX,IBDUZ,IBNAME,IBPID,IBBID,IBAGE,DFN
- S IBC=1,IBX=X,IBDUZ=DUZ
- D PAT,HDR,PATLINE,CHRG,INS,MAIL^IBAERR1
- Q
- MAIL ; for testing
- ; W !,XMSUB
- ; F IBC=1:1 Q:'$D(IBT(IBC)) W !,IBT(IBC)
- Q
- HDR ; formated for held charges
- N T,U,SL S T=$S('IBHOLDP:"NOT ON HOLD",1:"ON HOLD"),U=$S(IBSEQNO=1:"NEW ",IBSEQNO=3:"UPDATED ",1:"")
- ; if the parent event should have the soft-link that is needed to find
- ; the division
- S SL=$P(X,"^",16) S:SL SL=$G(^IB(SL,0)) S:'SL SL=X S SL=$P(SL,"^",4)
- S XMSUB=$E(IBNAME,1,8)_"("_IBBID_")"_"CATC CHRG W/INS"_"-"_$E($$DIV(SL),1,11)
- S IBT(IBC)="The following patient has active insurance and "_U_"Cat C charges "_T_".",IBC=IBC+1
- S IBT(IBC)="You need to immediately process the charges to the insurance company.",IBC=IBC+1
- Q
- PAT ; gets patient demographic data
- N VAERR,VADM,X
- S DFN=+$P(IBX,"^",2) D DEM^VADPT I VAERR K VADM
- S IBNAME=$$PR($G(VADM(1)),26),IBAGE=$$PR($G(VADM(4)),3),IBPID=$G(VA("PID")),IBBID=$G(VA("BID"))
- Q
- PATLINE ; sets up lines with patient data
- S IBT(IBC)="",IBC=IBC+1,IBT(IBC)="Name: "_IBNAME_" Age : "_IBAGE_" Pt. ID: "_IBPID,IBC=IBC+1
- Q
- CHRG ; gets charge data and sets up charge lines
- N TP,FR,TO
- S Y=$P(IBX,"^",14) D:Y DD^%DT S FR=Y
- S Y=$P(IBX,"^",15) D:Y DD^%DT S TO=Y
- S TP=$P(IBX,"^",3) S:TP TP=$P($G(^IBE(350.1,TP,0)),"^",3) S:TP TP=$P($$CATN^PRCAFN(TP),"^",2)
- S IBT(IBC)="Type: "_$$PR(TP,28)_" Amount : $"_+$P(IBX,"^",7),IBC=IBC+1
- S IBT(IBC)="From: "_$$PR(FR,28)_" To : "_TO,IBC=IBC+1
- Q
- INS ; gets insurance data and sets up insurance lines
- N I,CO,P,G,GNB,W,E,Y,C
- S IBT(IBC)="",IBC=IBC+1,IBT(IBC)="INSURANCE INFORMATION:",IBC=IBC+1
- S I="" F S I=$O(IBDD(I)) Q:'I D
- .S CO=$P(IBDD(I),"^",1),CO=$P(^DIC(36,CO,0),"^",1),CO=$$PR(CO,25)
- .S P=$$PR($P(IBDD(I),"^",2),21)
- .S Y=$P(IBDD(I),"^",6),C=$P(^DD(2.312,6,0),"^",2) D Y^DIQ S W=$$PR(Y,25)
- .S Y=$P(IBDD(I),"^",4) D:Y DD^%DT S E=Y
- .S G=$$PR($P(IBDD(I),"^",15),25)
- .S GNB=$P(IBDD(I),"^",3)
- .S IBT(IBC)="Company: "_CO_" Policy#: "_P,IBC=IBC+1
- .S IBT(IBC)="Whose : "_W_" Expires: "_E,IBC=IBC+1
- .S IBT(IBC)="Group : "_G_" Group# : "_GNB,IBC=IBC+1
- .S IBT(IBC)="",IBC=IBC+1
- Q
- PR(STR,LEN) ; pad right
- N B S STR=$E(STR,1,LEN),$P(B," ",LEN-$L(STR))=" "
- Q STR_$G(B)
- DIV(SL) ; returns the division with the softlink as input
- N IBDIV,IBWARD,IBFILE,IBIEN
- S:SL[";" SL=$P(SL,";",1)
- S IBFILE=$P(SL,":",1),IBIEN=$P(SL,":",2)
- S IBDIV=""
- I IBFILE=409.68,IBIEN S IBDIV=$P($G(^SCE(IBIEN,0)),"^",11)
- I IBFILE=44,IBIEN S IBDIV=$P($G(^SC(IBIEN,0)),"^",15)
- I IBFILE=405,IBIEN S IBWARD=$P($G(^DGPM(IBIEN,0)),"^",6) I IBWARD S IBDIV=$P($G(^DIC(42,IBWARD,0)),"^",11)
- I IBDIV S IBDIV=$P($G(^DG(40.8,IBDIV,0)),"^",1)
- I IBDIV="" S IBDIV="DIV UNKNWN"
- Q IBDIV
- IBRBUL ;ALB/CJM - CAT C HOLD CHARGE BULLETIN ; 02-MAR-92
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ; This bulletin is sent even if the local site has chosen
- +4 ; not to hold Cat C charges. In that case, IBHOLDP should be set = 0.
- +5 ; requires: IBDD() = internal node in patient file of valid ins.
- +6 ; DUZ
- +7 ; X = 0 node of IB BILLING ACTION
- +8 ; IBHOLDP = 1 if charge on hold, = 0 otherwise
- +9 ; IBSEQNO = 1 if the charges are new, 3 if updated
- BULL NEW IBT,IBC,XMSUB,XMY,XMDUZ,XMTEXT,IBX,IBDUZ,IBNAME,IBPID,IBBID,IBAGE,DFN
- +1 SET IBC=1
- SET IBX=X
- SET IBDUZ=DUZ
- +2 DO PAT
- DO HDR
- DO PATLINE
- DO CHRG
- DO INS
- DO MAIL^IBAERR1
- +3 QUIT
- MAIL ; for testing
- +1 ; W !,XMSUB
- +2 ; F IBC=1:1 Q:'$D(IBT(IBC)) W !,IBT(IBC)
- +3 QUIT
- HDR ; formated for held charges
- +1 NEW T,U,SL
- SET T=$SELECT('IBHOLDP:"NOT ON HOLD",1:"ON HOLD")
- SET U=$SELECT(IBSEQNO=1:"NEW ",IBSEQNO=3:"UPDATED ",1:"")
- +2 ; if the parent event should have the soft-link that is needed to find
- +3 ; the division
- +4 SET SL=$PIECE(X,"^",16)
- IF SL
- SET SL=$GET(^IB(SL,0))
- IF 'SL
- SET SL=X
- SET SL=$PIECE(SL,"^",4)
- +5 SET XMSUB=$EXTRACT(IBNAME,1,8)_"("_IBBID_")"_"CATC CHRG W/INS"_"-"_$EXTRACT($$DIV(SL),1,11)
- +6 SET IBT(IBC)="The following patient has active insurance and "_U_"Cat C charges "_T_"."
- SET IBC=IBC+1
- +7 SET IBT(IBC)="You need to immediately process the charges to the insurance company."
- SET IBC=IBC+1
- +8 QUIT
- PAT ; gets patient demographic data
- +1 NEW VAERR,VADM,X
- +2 SET DFN=+$PIECE(IBX,"^",2)
- DO DEM^VADPT
- IF VAERR
- KILL VADM
- +3 SET IBNAME=$$PR($GET(VADM(1)),26)
- SET IBAGE=$$PR($GET(VADM(4)),3)
- SET IBPID=$GET(VA("PID"))
- SET IBBID=$GET(VA("BID"))
- +4 QUIT
- PATLINE ; sets up lines with patient data
- +1 SET IBT(IBC)=""
- SET IBC=IBC+1
- SET IBT(IBC)="Name: "_IBNAME_" Age : "_IBAGE_" Pt. ID: "_IBPID
- SET IBC=IBC+1
- +2 QUIT
- CHRG ; gets charge data and sets up charge lines
- +1 NEW TP,FR,TO
- +2 SET Y=$PIECE(IBX,"^",14)
- IF Y
- DO DD^%DT
- SET FR=Y
- +3 SET Y=$PIECE(IBX,"^",15)
- IF Y
- DO DD^%DT
- SET TO=Y
- +4 SET TP=$PIECE(IBX,"^",3)
- IF TP
- SET TP=$PIECE($GET(^IBE(350.1,TP,0)),"^",3)
- IF TP
- SET TP=$PIECE($$CATN^PRCAFN(TP),"^",2)
- +5 SET IBT(IBC)="Type: "_$$PR(TP,28)_" Amount : $"_+$PIECE(IBX,"^",7)
- SET IBC=IBC+1
- +6 SET IBT(IBC)="From: "_$$PR(FR,28)_" To : "_TO
- SET IBC=IBC+1
- +7 QUIT
- INS ; gets insurance data and sets up insurance lines
- +1 NEW I,CO,P,G,GNB,W,E,Y,C
- +2 SET IBT(IBC)=""
- SET IBC=IBC+1
- SET IBT(IBC)="INSURANCE INFORMATION:"
- SET IBC=IBC+1
- +3 SET I=""
- FOR
- SET I=$ORDER(IBDD(I))
- IF 'I
- QUIT
- Begin DoDot:1
- +4 SET CO=$PIECE(IBDD(I),"^",1)
- SET CO=$PIECE(^DIC(36,CO,0),"^",1)
- SET CO=$$PR(CO,25)
- +5 SET P=$$PR($PIECE(IBDD(I),"^",2),21)
- +6 SET Y=$PIECE(IBDD(I),"^",6)
- SET C=$PIECE(^DD(2.312,6,0),"^",2)
- DO Y^DIQ
- SET W=$$PR(Y,25)
- +7 SET Y=$PIECE(IBDD(I),"^",4)
- IF Y
- DO DD^%DT
- SET E=Y
- +8 SET G=$$PR($PIECE(IBDD(I),"^",15),25)
- +9 SET GNB=$PIECE(IBDD(I),"^",3)
- +10 SET IBT(IBC)="Company: "_CO_" Policy#: "_P
- SET IBC=IBC+1
- +11 SET IBT(IBC)="Whose : "_W_" Expires: "_E
- SET IBC=IBC+1
- +12 SET IBT(IBC)="Group : "_G_" Group# : "_GNB
- SET IBC=IBC+1
- +13 SET IBT(IBC)=""
- SET IBC=IBC+1
- End DoDot:1
- +14 QUIT
- PR(STR,LEN) ; pad right
- +1 NEW B
- SET STR=$EXTRACT(STR,1,LEN)
- SET $PIECE(B," ",LEN-$LENGTH(STR))=" "
- +2 QUIT STR_$GET(B)
- DIV(SL) ; returns the division with the softlink as input
- +1 NEW IBDIV,IBWARD,IBFILE,IBIEN
- +2 IF SL[";"
- SET SL=$PIECE(SL,";",1)
- +3 SET IBFILE=$PIECE(SL,":",1)
- SET IBIEN=$PIECE(SL,":",2)
- +4 SET IBDIV=""
- +5 IF IBFILE=409.68
- IF IBIEN
- SET IBDIV=$PIECE($GET(^SCE(IBIEN,0)),"^",11)
- +6 IF IBFILE=44
- IF IBIEN
- SET IBDIV=$PIECE($GET(^SC(IBIEN,0)),"^",15)
- +7 IF IBFILE=405
- IF IBIEN
- SET IBWARD=$PIECE($GET(^DGPM(IBIEN,0)),"^",6)
- IF IBWARD
- SET IBDIV=$PIECE($GET(^DIC(42,IBWARD,0)),"^",11)
- +8 IF IBDIV
- SET IBDIV=$PIECE($GET(^DG(40.8,IBDIV,0)),"^",1)
- +9 IF IBDIV=""
- SET IBDIV="DIV UNKNWN"
- +10 QUIT IBDIV
