IBCSCH1 ;ALB/MRL - BILLING HELPS (CONTINUED) ;01 JUN 88 12:00
;;2.0;INTEGRATED BILLING;**106,125,51,245,266,395,458,461**;21-MAR-94;Build 58
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;MAP TO DGCRSCH1
;
1 W !!,"DO YOU WISH TO ADD/EDIT INSURANCE COMPANY DATA FOR THIS PATIENT" S %=2 D YN^DICN S IBADI=$S(%=1!(%=-1):%,1:0)
I '% W !!?4,"YES - And I'll prompt you so that you may add insurance data to the PATIENT",!?9,"file for this patient.",!?4,"NO - To bypass this editing of the PATIENT file." G 1
Q
;
2 W !!,"If you updated insurance information for any policy which is already specified",!,"as either a PRIMARY, SECONDARY or TERIARY for this billing episode, you will"
W !,"need to press the <RETURN> key through the following prompts in order to insure",!,"that these new values are properly stored. If you fail to do so, i.e.,"
W !,"enter an up-arrow, the new values will not be stored as part of this billing",!,"record." Q
3 I '$D(IBIFN),$D(DA) S IBIFN=DA
W !,"If a procedure is linked as a prescription to a rev code, it cannot be deleted",!
W:$P(^DGCR(399,IBIFN,0),"^",5)<3 !!?4," - Enter the alphanumeric designation of your choice from",!?7,"the display (e.g. 'A1') to input one of the codes shown",!?7,"above into this billing record."
I $P(^IBE(350.9,1,1),U,15)'=1 G 4
S DGCODMET=$P(^DGCR(399,IBIFN,0),"^",9),DGCODMET=$S(DGCODMET=9:"ICD",DGCODMET="":"",1:"CPT")
W !!?4," - Enter the name or code number of an ",$S($D(IBPY):"ICD DIAGNOSIS ",1:DGCODMET_" PROCEDURE "),"CODE",!?7,"not displayed above to input a ",$S($D(IBPY):"DIAGNOSIS",1:"PROCEDURE")," code"
I $P(^DGCR(399,IBIFN,0),"^",5)>2 W "." G 4
W " not found",!?7,"in the PTF record into this billing record, or '??' for ",!?7,"a list of all ",$S($D(IBPY):"ICD DIAGNOSIS ",1:DGCODMET_" PROCEDURE "),"CODES."
4 W !!?4," - Enter <RETURN> to accept the default ",$S($D(IBPY):"DIAGNOSIS ",1:"PROCEDURE "),"code, or",!?7,"'^' to abort.",!!
K DGCODMET
Q
;
DISPPRC(IBIFN) ; display procedures
N IBHDR,IBHDR1,IBD,IBN,IBI,IBX,IBQ,IBLN,IBPR,IBPRD,IBDT,IBDV,IBCL,IBPV,IBLC,PRCARR,IBMOD,IBSUS,IBDATE
S IBQ=0
;
I '$O(^DGCR(399,+$G(IBIFN),"CP",0)) W !!?5,"No Codes Entered!",! D PAUSE^VALM1 Q
;
S IBDATE=$$BDATE^IBACSV(IBIFN)
S IBHDR="W @IOF,!,""Procedures Assigned to this Bill"",!,""Code"",?10,""Procedure"",?35,""PO"",?38,""Date"",?48,""Div"",?55,""Clinic"",?68,""Provider"" X IBHDR1"
S IBHDR1="W !,""--------------------------------------------------------------------------------"" S IBLC=2"
;
X IBHDR D PRCDT^IBCU71(+IBIFN,.PRCARR)
S IBD="" F S IBD=$O(PRCARR(IBD)) Q:IBD="" D Q:IBQ
. S IBN="" F S IBN=$O(PRCARR(IBD,IBN)) Q:IBN="" D Q:IBQ
.. S IBI=0 F S IBI=$O(PRCARR(IBD,IBN,IBI)) Q:'IBI D I IBLC>19 S IBQ=$$PAUSE(IBLC) Q:IBQ X IBHDR
... S IBLN=$G(PRCARR(IBD,IBN,IBI)),(IBPR,IBPRD,IBDT,IBDV,IBCL,IBPV,IBSUS)="",IBLC=IBLC+1
... S IBX=$$PRCNM($P(IBLN,U,1),IBD),IBPR=$P(IBX,U,1),IBPRD=$P(IBX,U,2)
... S IBDT=$P(IBLN,U,2),IBDT=$E(IBDT,4,5)_"/"_$E(IBDT,6,7)_"/"_$E(IBDT,2,3)
... I +$P(IBLN,U,6) S IBDV=$P($G(^DG(40.8,+$P(IBLN,U,6),0)),U,2)
... I +$P(IBLN,U,7) S IBCL=$P($G(^SC(+$P(IBLN,U,7),0)),U,1)
... I +$P(IBLN,U,18) S IBPV=$P($G(^VA(200,+$P(IBLN,U,18),0)),U,1)
... I +$P(IBLN,U,16) S IBSUS=$P(IBLN,U,16)_"mn"
... I +$P(IBLN,U,21) S IBSUS=$P(IBLN,U,21)_"ml"
... I +$P(IBLN,U,22) S IBSUS=$P(IBLN,U,22)_"hr"
... ;
... W !,$E(IBPR,1,7),?8,$E(IBPRD,1,19),?29,IBSUS,?35,$P(IBLN,U,4),?38,IBDT,?48,IBDV,?55,$E(IBCL,1,11),?68,$E(IBPV,1,12)
... S IBX=$$MODLST^IBEFUNC2($$GETMOD^IBEFUNC(IBIFN,IBI),1,.IBX,IBD)
... I IBX'="" F IBMOD=1:1:$L(IBX,",") W !,?10,$P(IBX,",",IBMOD),?15,$P($G(IBX(1)),",",IBMOD) S IBLC=IBLC+1
I 'IBI,'IBQ S IBQ=$$PAUSE(IBLC)
Q
;
PRCNM(PRC,EFDT) ; return procedure name, input first piece of CP node -
; (in variable pointer format)
; output: code ^ name
N IBNM
S IBNM=$$PRCD^IBCEF1($G(PRC),1,$G(EFDT))
I $TR(IBNM,U)="" D
. S IBNM="NO ENTRY FOUND^"
E D
. S IBNM=$P(IBNM,U,2,3)
Q IBNM
;
PAUSE(CNT) ;
N IBI F IBI=CNT:1:20 W !
N DIR,DUOUT,DTOUT,DIRUT,IBX,X,Y S IBX=0,DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S IBX=1
Q IBX
;
DISPRX(IBIFN) ; display prescriptions
N IBHDR,IBHDR1,IBX,IBZ,IBRXL,IBNPI,IBRX,IBQ,IBORG
S IBQ=0
;
I '$O(^IBA(362.4,"AIFN"_IBIFN,0)) W !!?5,"No Prescriptions Entered!",! D PAUSE^VALM1 Q
;
; get NPIs
S IBX=$$RXSITE^IBCEF73A(IBIFN,.IBRXL)
;
S IBHDR="W @IOF,!,""Prescriptions Assigned to this Bill"" X IBHDR1"
S IBHDR1="W !,""--------------------------------------------------------------------------------"" "
;
X IBHDR
S IBRX=0 F S IBRX=$O(^IBA(362.4,"AIFN"_IBIFN,IBRX)) Q:'IBRX!(IBQ) S IBX=0 F S IBX=$O(^IBA(362.4,"AIFN"_IBIFN,IBRX,IBX)) Q:'IBX!(IBQ) D
. S IBZ=$G(^IBA(362.4,IBX,0))
. W !?5,"RX #: ",$P(IBZ,"^")
. W ?50,"DATE: ",$$FMTE^XLFDT($P(IBZ,"^",3))
. W !?5,"DRUG: ",$$EXTERNAL^DILFD(362.4,.04,"",$P(IBZ,"^",4))
. W ?50,"NDC: ",$P(IBZ,"^",8)
. W !?5,"DAYS SUPPLY: ",$P(IBZ,"^",6)
. W ?50,"QUANTITY: ",$P(IBZ,"^",7)
. S IBORG=$G(IBRXL(+$P(IBZ,"^",5),+$P(IBZ,"^",3)))
. ; ia #4532
. S IBNPI=$S(IBORG:$P($$NPI^XUSNPI("Organization_ID",IBORG),U),1:"")
. W !?5,"NPI INSTITUTION: ",$S(IBORG:$$EXTERNAL^DILFD(350.9,.02,"",IBORG),1:"")
. W ?50,"RX NPI: ",$S(IBNPI>0:IBNPI,1:"")
. W !?5,"PROVIDER: ",$S($P(IBZ,"^",5):$$RXAPI1^IBNCPUT1($P(IBZ,"^",5),4),1:""),!
. I $Y+7>IOSL S IBQ=$$PAUSE(0)
D PAUSE^VALM1
;
Q
;
EDITRNB(IBIFN) ; add/edit RNB and Comments for CT entries associated with bill, ?RNB Help function
; sets IBNOCANC indicating bill not cancelled, function sets it to number of associated CT entries
N IBNOCANC S IBNOCANC=0 I '$G(IBIFN) Q
W @IOF,!,"Reason Not Billable for Claims Tracking Entries associated with this Bill:",!,$TR($J(" ",74)," ","-")
W !!,"Episodes not fully billed may have a Reason Not Billable entered on the Claims",!,"Tracking entry. Only enter an RNB if the episode is not fully billed.",!
;
D ^IBCC1 I '$G(IBNOCANC) W !!,"No associated Claims Tracking entries found.",!!
;
D PAUSE(19)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSCH1 6106 printed Apr 09, 2024@21:37:17 Page 2
IBCSCH1 ;ALB/MRL - BILLING HELPS (CONTINUED) ;01 JUN 88 12:00
+1 ;;2.0;INTEGRATED BILLING;**106,125,51,245,266,395,458,461**;21-MAR-94;Build 58
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRSCH1
+5 ;
1 WRITE !!,"DO YOU WISH TO ADD/EDIT INSURANCE COMPANY DATA FOR THIS PATIENT"
SET %=2
DO YN^DICN
SET IBADI=$SELECT(%=1!(%=-1):%,1:0)
+1 IF '%
WRITE !!?4,"YES - And I'll prompt you so that you may add insurance data to the PATIENT",!?9,"file for this patient.",!?4,"NO - To bypass this editing of the PATIENT file."
GOTO 1
+2 QUIT
+3 ;
2 WRITE !!,"If you updated insurance information for any policy which is already specified",!,"as either a PRIMARY, SECONDARY or TERIARY for this billing episode, you will"
+1 WRITE !,"need to press the <RETURN> key through the following prompts in order to insure",!,"that these new values are properly stored. If you fail to do so, i.e.,"
+2 WRITE !,"enter an up-arrow, the new values will not be stored as part of this billing",!,"record."
QUIT
3 IF '$DATA(IBIFN)
IF $DATA(DA)
SET IBIFN=DA
+1 WRITE !,"If a procedure is linked as a prescription to a rev code, it cannot be deleted",!
+2 if $PIECE(^DGCR(399,IBIFN,0),"^",5)<3
WRITE !!?4," - Enter the alphanumeric designation of your choice from",!?7,"the display (e.g. 'A1') to input one of the codes shown",!?7,"above into this billing record."
+3 IF $PIECE(^IBE(350.9,1,1),U,15)'=1
GOTO 4
+4 SET DGCODMET=$PIECE(^DGCR(399,IBIFN,0),"^",9)
SET DGCODMET=$SELECT(DGCODMET=9:"ICD",DGCODMET="":"",1:"CPT")
+5 WRITE !!?4," - Enter the name or code number of an ",$SELECT($DATA(IBPY):"ICD DIAGNOSIS ",1:DGCODMET_" PROCEDURE "),"CODE",!?7,"not displayed above to input a ",$SELECT($DATA(IBPY):"DIAGNOSIS",1:"PROCEDURE")," code"
+6 IF $PIECE(^DGCR(399,IBIFN,0),"^",5)>2
WRITE "."
GOTO 4
+7 WRITE " not found",!?7,"in the PTF record into this billing record, or '??' for ",!?7,"a list of all ",$SELECT($DATA(IBPY):"ICD DIAGNOSIS ",1:DGCODMET_" PROCEDURE "),"CODES."
4 WRITE !!?4," - Enter <RETURN> to accept the default ",$SELECT($DATA(IBPY):"DIAGNOSIS ",1:"PROCEDURE "),"code, or",!?7,"'^' to abort.",!!
+1 KILL DGCODMET
+2 QUIT
+3 ;
DISPPRC(IBIFN) ; display procedures
+1 NEW IBHDR,IBHDR1,IBD,IBN,IBI,IBX,IBQ,IBLN,IBPR,IBPRD,IBDT,IBDV,IBCL,IBPV,IBLC,PRCARR,IBMOD,IBSUS,IBDATE
+2 SET IBQ=0
+3 ;
+4 IF '$ORDER(^DGCR(399,+$GET(IBIFN),"CP",0))
WRITE !!?5,"No Codes Entered!",!
DO PAUSE^VALM1
QUIT
+5 ;
+6 SET IBDATE=$$BDATE^IBACSV(IBIFN)
+7 SET IBHDR="W @IOF,!,""Procedures Assigned to this Bill"",!,""Code"",?10,""Procedure"",?35,""PO"",?38,""Date"",?48,""Div"",?55,""Clinic"",?68,""Provider"" X IBHDR1"
+8 SET IBHDR1="W !,""--------------------------------------------------------------------------------"" S IBLC=2"
+9 ;
+10 XECUTE IBHDR
DO PRCDT^IBCU71(+IBIFN,.PRCARR)
+11 SET IBD=""
FOR
SET IBD=$ORDER(PRCARR(IBD))
if IBD=""
QUIT
Begin DoDot:1
+12 SET IBN=""
FOR
SET IBN=$ORDER(PRCARR(IBD,IBN))
if IBN=""
QUIT
Begin DoDot:2
+13 SET IBI=0
FOR
SET IBI=$ORDER(PRCARR(IBD,IBN,IBI))
if 'IBI
QUIT
Begin DoDot:3
+14 SET IBLN=$GET(PRCARR(IBD,IBN,IBI))
SET (IBPR,IBPRD,IBDT,IBDV,IBCL,IBPV,IBSUS)=""
SET IBLC=IBLC+1
+15 SET IBX=$$PRCNM($PIECE(IBLN,U,1),IBD)
SET IBPR=$PIECE(IBX,U,1)
SET IBPRD=$PIECE(IBX,U,2)
+16 SET IBDT=$PIECE(IBLN,U,2)
SET IBDT=$EXTRACT(IBDT,4,5)_"/"_$EXTRACT(IBDT,6,7)_"/"_$EXTRACT(IBDT,2,3)
+17 IF +$PIECE(IBLN,U,6)
SET IBDV=$PIECE($GET(^DG(40.8,+$PIECE(IBLN,U,6),0)),U,2)
+18 IF +$PIECE(IBLN,U,7)
SET IBCL=$PIECE($GET(^SC(+$PIECE(IBLN,U,7),0)),U,1)
+19 IF +$PIECE(IBLN,U,18)
SET IBPV=$PIECE($GET(^VA(200,+$PIECE(IBLN,U,18),0)),U,1)
+20 IF +$PIECE(IBLN,U,16)
SET IBSUS=$PIECE(IBLN,U,16)_"mn"
+21 IF +$PIECE(IBLN,U,21)
SET IBSUS=$PIECE(IBLN,U,21)_"ml"
+22 IF +$PIECE(IBLN,U,22)
SET IBSUS=$PIECE(IBLN,U,22)_"hr"
+23 ;
+24 WRITE !,$EXTRACT(IBPR,1,7),?8,$EXTRACT(IBPRD,1,19),?29,IBSUS,?35,$PIECE(IBLN,U,4),?38,IBDT,?48,IBDV,?55,$EXTRACT(IBCL,1,11),?68,$EXTRACT(IBPV,1,12)
+25 SET IBX=$$MODLST^IBEFUNC2($$GETMOD^IBEFUNC(IBIFN,IBI),1,.IBX,IBD)
+26 IF IBX'=""
FOR IBMOD=1:1:$LENGTH(IBX,",")
WRITE !,?10,$PIECE(IBX,",",IBMOD),?15,$PIECE($GET(IBX(1)),",",IBMOD)
SET IBLC=IBLC+1
End DoDot:3
IF IBLC>19
SET IBQ=$$PAUSE(IBLC)
if IBQ
QUIT
XECUTE IBHDR
End DoDot:2
if IBQ
QUIT
End DoDot:1
if IBQ
QUIT
+27 IF 'IBI
IF 'IBQ
SET IBQ=$$PAUSE(IBLC)
+28 QUIT
+29 ;
PRCNM(PRC,EFDT) ; return procedure name, input first piece of CP node -
+1 ; (in variable pointer format)
+2 ; output: code ^ name
+3 NEW IBNM
+4 SET IBNM=$$PRCD^IBCEF1($GET(PRC),1,$GET(EFDT))
+5 IF $TRANSLATE(IBNM,U)=""
Begin DoDot:1
+6 SET IBNM="NO ENTRY FOUND^"
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 SET IBNM=$PIECE(IBNM,U,2,3)
End DoDot:1
+9 QUIT IBNM
+10 ;
PAUSE(CNT) ;
+1 NEW IBI
FOR IBI=CNT:1:20
WRITE !
+2 NEW DIR,DUOUT,DTOUT,DIRUT,IBX,X,Y
SET IBX=0
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET IBX=1
+3 QUIT IBX
+4 ;
DISPRX(IBIFN) ; display prescriptions
+1 NEW IBHDR,IBHDR1,IBX,IBZ,IBRXL,IBNPI,IBRX,IBQ,IBORG
+2 SET IBQ=0
+3 ;
+4 IF '$ORDER(^IBA(362.4,"AIFN"_IBIFN,0))
WRITE !!?5,"No Prescriptions Entered!",!
DO PAUSE^VALM1
QUIT
+5 ;
+6 ; get NPIs
+7 SET IBX=$$RXSITE^IBCEF73A(IBIFN,.IBRXL)
+8 ;
+9 SET IBHDR="W @IOF,!,""Prescriptions Assigned to this Bill"" X IBHDR1"
+10 SET IBHDR1="W !,""--------------------------------------------------------------------------------"" "
+11 ;
+12 XECUTE IBHDR
+13 SET IBRX=0
FOR
SET IBRX=$ORDER(^IBA(362.4,"AIFN"_IBIFN,IBRX))
if 'IBRX!(IBQ)
QUIT
SET IBX=0
FOR
SET IBX=$ORDER(^IBA(362.4,"AIFN"_IBIFN,IBRX,IBX))
if 'IBX!(IBQ)
QUIT
Begin DoDot:1
+14 SET IBZ=$GET(^IBA(362.4,IBX,0))
+15 WRITE !?5,"RX #: ",$PIECE(IBZ,"^")
+16 WRITE ?50,"DATE: ",$$FMTE^XLFDT($PIECE(IBZ,"^",3))
+17 WRITE !?5,"DRUG: ",$$EXTERNAL^DILFD(362.4,.04,"",$PIECE(IBZ,"^",4))
+18 WRITE ?50,"NDC: ",$PIECE(IBZ,"^",8)
+19 WRITE !?5,"DAYS SUPPLY: ",$PIECE(IBZ,"^",6)
+20 WRITE ?50,"QUANTITY: ",$PIECE(IBZ,"^",7)
+21 SET IBORG=$GET(IBRXL(+$PIECE(IBZ,"^",5),+$PIECE(IBZ,"^",3)))
+22 ; ia #4532
+23 SET IBNPI=$SELECT(IBORG:$PIECE($$NPI^XUSNPI("Organization_ID",IBORG),U),1:"")
+24 WRITE !?5,"NPI INSTITUTION: ",$SELECT(IBORG:$$EXTERNAL^DILFD(350.9,.02,"",IBORG),1:"")
+25 WRITE ?50,"RX NPI: ",$SELECT(IBNPI>0:IBNPI,1:"")
+26 WRITE !?5,"PROVIDER: ",$SELECT($PIECE(IBZ,"^",5):$$RXAPI1^IBNCPUT1($PIECE(IBZ,"^",5),4),1:""),!
+27 IF $Y+7>IOSL
SET IBQ=$$PAUSE(0)
End DoDot:1
+28 DO PAUSE^VALM1
+29 ;
+30 QUIT
+31 ;
EDITRNB(IBIFN) ; add/edit RNB and Comments for CT entries associated with bill, ?RNB Help function
+1 ; sets IBNOCANC indicating bill not cancelled, function sets it to number of associated CT entries
+2 NEW IBNOCANC
SET IBNOCANC=0
IF '$GET(IBIFN)
QUIT
+3 WRITE @IOF,!,"Reason Not Billable for Claims Tracking Entries associated with this Bill:",!,$TRANSLATE($JUSTIFY(" ",74)," ","-")
+4 WRITE !!,"Episodes not fully billed may have a Reason Not Billable entered on the Claims",!,"Tracking entry. Only enter an RNB if the episode is not fully billed.",!
+5 ;
+6 DO ^IBCC1
IF '$GET(IBNOCANC)
WRITE !!,"No associated Claims Tracking entries found.",!!
+7 ;
+8 DO PAUSE(19)
+9 QUIT
