- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCH1.m
r613 r623 1 IBCSCH1 ;ALB/MRL - BILLING HELPS (CONTINUED) ; 01 JUN 88 12:00 2 ;;2.0;INTEGRATED BILLING;**106,125,51,245,266,395**;21-MAR-94;Build 3 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 ;MAP TO DGCRSCH1 6 ; 7 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) 8 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 9 Q 10 ; 11 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" 12 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.," 13 W !,"enter an up-arrow, the new values will not be stored as part of this billing",!,"record." Q 14 3 I '$D(IBIFN),$D(DA) S IBIFN=DA 15 W !,"If a procedure is linked as a prescription to a rev code, it cannot be deleted",! 16 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." 17 I $P(^IBE(350.9,1,1),U,15)'=1 G 4 18 S DGCODMET=$P(^DGCR(399,IBIFN,0),"^",9),DGCODMET=$S(DGCODMET=9:"ICD",DGCODMET="":"",1:"CPT") 19 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" 20 I $P(^DGCR(399,IBIFN,0),"^",5)>2 W "." G 4 21 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." 22 4 W !!?4," - Enter <RETURN> to accept the default ",$S($D(IBPY):"DIAGNOSIS ",1:"PROCEDURE "),"code, or",!?7,"'^' to abort.",!! 23 K DGCODMET 24 Q 25 ; 26 DISPPRC(IBIFN) ; display procedures 27 N IBHDR,IBHDR1,IBD,IBN,IBI,IBX,IBQ,IBLN,IBPR,IBPRD,IBDT,IBDV,IBCL,IBPV,IBLC,PRCARR,IBMOD,IBSUS,IBDATE 28 S IBQ=0 29 ; 30 I '$O(^DGCR(399,+$G(IBIFN),"CP",0)) W !!?5,"No Codes Entered!",! D PAUSE^VALM1 Q 31 ; 32 S IBDATE=$$BDATE^IBACSV(IBIFN) 33 S IBHDR="W @IOF,!,""Procedures Assigned to this Bill"",!,""Code"",?10,""Procedure"",?35,""PO"",?38,""Date"",?48,""Div"",?55,""Clinic"",?68,""Provider"" X IBHDR1" 34 S IBHDR1="W !,""--------------------------------------------------------------------------------"" S IBLC=2" 35 ; 36 X IBHDR D PRCDT^IBCU71(+IBIFN,.PRCARR) 37 S IBD="" F S IBD=$O(PRCARR(IBD)) Q:IBD="" D Q:IBQ 38 . S IBN="" F S IBN=$O(PRCARR(IBD,IBN)) Q:IBN="" D Q:IBQ 39 .. 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 40 ... S IBLN=$G(PRCARR(IBD,IBN,IBI)),(IBPR,IBPRD,IBDT,IBDV,IBCL,IBPV,IBSUS)="",IBLC=IBLC+1 41 ... S IBX=$$PRCNM($P(IBLN,U,1),IBD),IBPR=$P(IBX,U,1),IBPRD=$P(IBX,U,2) 42 ... S IBDT=$P(IBLN,U,2),IBDT=$E(IBDT,4,5)_"/"_$E(IBDT,6,7)_"/"_$E(IBDT,2,3) 43 ... I +$P(IBLN,U,6) S IBDV=$P($G(^DG(40.8,+$P(IBLN,U,6),0)),U,2) 44 ... I +$P(IBLN,U,7) S IBCL=$P($G(^SC(+$P(IBLN,U,7),0)),U,1) 45 ... I +$P(IBLN,U,18) S IBPV=$P($G(^VA(200,+$P(IBLN,U,18),0)),U,1) 46 ... I +$P(IBLN,U,16) S IBSUS=$P(IBLN,U,16)_"mn" 47 ... I +$P(IBLN,U,21) S IBSUS=$P(IBLN,U,21)_"ml" 48 ... I +$P(IBLN,U,22) S IBSUS=$P(IBLN,U,22)_"hr" 49 ... ; 50 ... W !,$E(IBPR,1,6),?7,$E(IBPRD,1,20),?29,IBSUS,?35,$P(IBLN,U,4),?38,IBDT,?48,IBDV,?55,$E(IBCL,1,11),?68,$E(IBPV,1,12) 51 ... S IBX=$$MODLST^IBEFUNC2($$GETMOD^IBEFUNC(IBIFN,IBI),1,.IBX,IBD) 52 ... I IBX'="" F IBMOD=1:1:$L(IBX,",") W !,?10,$P(IBX,",",IBMOD),?15,$P($G(IBX(1)),",",IBMOD) S IBLC=IBLC+1 53 I 'IBI,'IBQ S IBQ=$$PAUSE(IBLC) 54 Q 55 ; 56 PRCNM(PRC,EFDT) ; return procedure name, input first piece of CP node - 57 ; (in variable pointer format) 58 ; output: code ^ name 59 N IBNM 60 S IBNM=$$PRCD^IBCEF1($G(PRC),1,$G(EFDT)) 61 I $TR(IBNM,U)="" D 62 . S IBNM="NO ENTRY FOUND^" 63 E D 64 . S IBNM=$P(IBNM,U,2,3) 65 Q IBNM 66 ; 67 PAUSE(CNT) ; 68 N IBI F IBI=CNT:1:20 W ! 69 N DIR,DUOUT,DTOUT,DIRUT,IBX,X,Y S IBX=0,DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S IBX=1 70 Q IBX 71 ; 72 DISPRX(IBIFN) ; display prescriptions 73 N IBHDR,IBHDR1,IBX,IBZ,IBRXL,IBNPI,IBRX,IBQ,IBORG 74 S IBQ=0 75 ; 76 I '$O(^IBA(362.4,"AIFN"_IBIFN,0)) W !!?5,"No Prescriptions Entered!",! D PAUSE^VALM1 Q 77 ; 78 ; get NPIs 79 S IBX=$$RXSITE^IBCEF73A(IBIFN,.IBRXL) 80 ; 81 S IBHDR="W @IOF,!,""Prescriptions Assigned to this Bill"" X IBHDR1" 82 S IBHDR1="W !,""--------------------------------------------------------------------------------"" " 83 ; 84 X IBHDR 85 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 86 . S IBZ=$G(^IBA(362.4,IBX,0)) 87 . W !?5,"RX #: ",$P(IBZ,"^") 88 . W ?50,"DATE: ",$$FMTE^XLFDT($P(IBZ,"^",3)) 89 . W !?5,"DRUG: ",$$EXTERNAL^DILFD(362.4,.04,"",$P(IBZ,"^",4)) 90 . W ?50,"NDC: ",$P(IBZ,"^",8) 91 . W !?5,"DAYS SUPPLY: ",$P(IBZ,"^",6) 92 . W ?50,"QUANTITY: ",$P(IBZ,"^",7) 93 . S IBORG=$G(IBRXL(+$P(IBZ,"^",5),+$P(IBZ,"^",3))) 94 . ; ia #4532 95 . S IBNPI=$S(IBORG:$P($$NPI^XUSNPI("Organization_ID",IBORG),U),1:"") 96 . W !?5,"NPI INSTITUTION: ",$S(IBORG:$$EXTERNAL^DILFD(350.9,.02,"",IBORG),1:"") 97 . W ?50,"RX NPI: ",$S(IBNPI>0:IBNPI,1:"") 98 . W !?5,"PROVIDER: ",$S($P(IBZ,"^",5):$$RXAPI1^IBNCPUT1($P(IBZ,"^",5),4),1:""),! 99 . I $Y+7>IOSL S IBQ=$$PAUSE(0) 100 D PAUSE^VALM1 101 ; 102 Q 103 ; 1 IBCSCH1 ;ALB/MRL - BILLING HELPS (CONTINUED) ; 01 JUN 88 12:00 2 ;;2.0;INTEGRATED BILLING;**106,125,51,245,266**;21-MAR-94 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 ;MAP TO DGCRSCH1 6 ; 7 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) 8 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 9 Q 10 ; 11 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" 12 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.," 13 W !,"enter an up-arrow, the new values will not be stored as part of this billing",!,"record." Q 14 3 I '$D(IBIFN),$D(DA) S IBIFN=DA 15 W !,"If a procedure is linked as a prescription to a rev code, it cannot be deleted",! 16 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." 17 I $P(^IBE(350.9,1,1),U,15)'=1 G 4 18 S DGCODMET=$P(^DGCR(399,IBIFN,0),"^",9),DGCODMET=$S(DGCODMET=9:"ICD",DGCODMET="":"",1:"CPT") 19 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" 20 I $P(^DGCR(399,IBIFN,0),"^",5)>2 W "." G 4 21 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." 22 4 W !!?4," - Enter <RETURN> to accept the default ",$S($D(IBPY):"DIAGNOSIS ",1:"PROCEDURE "),"code, or",!?7,"'^' to abort.",!! 23 K DGCODMET 24 Q 25 ; 26 DISPPRC(IBIFN) ; display procedures 27 N IBHDR,IBHDR1,IBD,IBN,IBI,IBX,IBQ,IBLN,IBPR,IBPRD,IBDT,IBDV,IBCL,IBPV,IBLC,PRCARR,IBMOD,IBSUS,IBDATE 28 S IBQ=0 29 ; 30 I '$O(^DGCR(399,+$G(IBIFN),"CP",0)) W !!?5,"No Codes Entered!",! D PAUSE^VALM1 Q 31 ; 32 S IBDATE=$$BDATE^IBACSV(IBIFN) 33 S IBHDR="W @IOF,!,""Procedures Assigned to this Bill"",!,""Code"",?10,""Procedure"",?35,""PO"",?38,""Date"",?48,""Div"",?55,""Clinic"",?68,""Provider"" X IBHDR1" 34 S IBHDR1="W !,""--------------------------------------------------------------------------------"" S IBLC=2" 35 ; 36 X IBHDR D PRCDT^IBCU71(+IBIFN,.PRCARR) 37 S IBD="" F S IBD=$O(PRCARR(IBD)) Q:IBD="" D Q:IBQ 38 . S IBN="" F S IBN=$O(PRCARR(IBD,IBN)) Q:IBN="" D Q:IBQ 39 .. 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 40 ... S IBLN=$G(PRCARR(IBD,IBN,IBI)),(IBPR,IBPRD,IBDT,IBDV,IBCL,IBPV,IBSUS)="",IBLC=IBLC+1 41 ... S IBX=$$PRCNM($P(IBLN,U,1),IBD),IBPR=$P(IBX,U,1),IBPRD=$P(IBX,U,2) 42 ... S IBDT=$P(IBLN,U,2),IBDT=$E(IBDT,4,5)_"/"_$E(IBDT,6,7)_"/"_$E(IBDT,2,3) 43 ... I +$P(IBLN,U,6) S IBDV=$P($G(^DG(40.8,+$P(IBLN,U,6),0)),U,2) 44 ... I +$P(IBLN,U,7) S IBCL=$P($G(^SC(+$P(IBLN,U,7),0)),U,1) 45 ... I +$P(IBLN,U,18) S IBPV=$P($G(^VA(200,+$P(IBLN,U,18),0)),U,1) 46 ... I +$P(IBLN,U,16) S IBSUS=$P(IBLN,U,16)_"mn" 47 ... I +$P(IBLN,U,21) S IBSUS=$P(IBLN,U,21)_"ml" 48 ... I +$P(IBLN,U,22) S IBSUS=$P(IBLN,U,22)_"hr" 49 ... ; 50 ... W !,$E(IBPR,1,6),?7,$E(IBPRD,1,20),?29,IBSUS,?35,$P(IBLN,U,4),?38,IBDT,?48,IBDV,?55,$E(IBCL,1,11),?68,$E(IBPV,1,12) 51 ... S IBX=$$MODLST^IBEFUNC2($$GETMOD^IBEFUNC(IBIFN,IBI),1,.IBX,IBD) 52 ... I IBX'="" F IBMOD=1:1:$L(IBX,",") W !,?10,$P(IBX,",",IBMOD),?15,$P($G(IBX(1)),",",IBMOD) S IBLC=IBLC+1 53 I 'IBI,'IBQ S IBQ=$$PAUSE(IBLC) 54 Q 55 ; 56 PRCNM(PRC,EFDT) ; return procedure name, input first piece of CP node - 57 ; (in variable pointer format) 58 ; output: code ^ name 59 N IBNM 60 S IBNM=$$PRCD^IBCEF1($G(PRC),1,$G(EFDT)) 61 I $TR(IBNM,U)="" D 62 . S IBNM="NO ENTRY FOUND^" 63 E D 64 . S IBNM=$P(IBNM,U,2,3) 65 Q IBNM 66 ; 67 PAUSE(CNT) ; 68 N IBI F IBI=CNT:1:20 W ! 69 N DIR,DUOUT,DTOUT,DIRUT,IBX,X,Y S IBX=0,DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S IBX=1 70 Q IBX
Note:
See TracChangeset
for help on using the changeset viewer.
