- 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/IBCSC8H.m
r613 r623 1 IBCSC8H ;ALB/ARH - MCCR SCREEN 8 (BILL SPECIFIC INFO) CMS-1500 ;4/21/92 2 ;;2.0;INTEGRATED BILLING;**51,137,207,210,232,155,320,343,349,371**;21-MAR-94;Build 57 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; CMS-1500 screen 8 5 ; 6 ; MAP TO DGCRSC8H 7 ; 8 EN N I,IB,Y,Z 9 D ^IBCSCU S IBSR=8,IBSR1="H",IBV1="00000000" S:IBV IBV1="11111111" F I="U","U1","UF2","UF3","U2","M","TX",0,"U3" S IB(I)=$G(^DGCR(399,IBIFN,I)) 10 N IBZ,IBPRV,IBDATE,IBREQ,IBMRASEC,IBZ1 11 ; 12 S IBDATE=$$BDATE^IBACSV(IBIFN) ; Date of service for the bill 13 S IBPRV="" 14 D GETPRV^IBCEU(IBIFN,"ALL",.IBPRV) 15 K IB("PRV") 16 S IBZ=0 F S IBZ=$O(IBPRV(IBZ)) Q:'IBZ I $O(IBPRV(IBZ,0))!$D(IBPRV(IBZ,"NOTOPT")) M IB("PRV",IBZ)=IBPRV(IBZ) 17 ; 18 D H^IBCSCU 19 S Z=1,IBW=1 X IBWW W " Unable To Work From: " S Y=$P(IB("U"),U,16) X ^DD("DD") W $S(Y'="":Y,1:IBUN) 20 W !?4,"Unable To Work To : " S Y=$P(IB("U"),U,17) X ^DD("DD") W $S(Y'="":Y,1:IBUN) 21 S Z=2,IBW=1 X IBWW W " Admitting Dx : " S IBZ=$$ICD9^IBACSV(+IB("U2"),IBDATE) W $S(IBZ'="":$P(IBZ,U)_" - "_$P(IBZ,U,3),1:IBUN) 22 S IBZ="",IBZ=$S($P(IB("UF3"),U,4)]"":"Pri: "_$P(IB("UF3"),U,4),1:"")_$S($P(IB("UF3"),U,5)'="":" Sec: "_$P(IB("UF3"),U,5),1:"")_$S($P(IB("UF3"),U,6)'="":" Ter: "_$P(IB("UF3"),U,6),1:"") 23 S:IBZ="" IBZ=IBUN 24 W !,?4,"ICN/DCN(s) : ",IBZ 25 S IBZ=$$CKPROV^IBCEU(IBIFN,3) 26 S IBZ="",IBZ=$S($P(IB("U"),U,13)]"":"Pri: "_$P(IB("U"),U,13),1:"")_$S($P(IB("U2"),U,8)'="":" Sec: "_$P(IB("U2"),U,8),1:"")_$S($P(IB("U2"),U,9)'="":" Ter: "_$P(IB("U2"),U,9),1:"") 27 S:IBZ="" IBZ=IBUN 28 W !?4,"Tx Auth. Code(s) : ",IBZ 29 S Z=3,IBW=1 X IBWW 30 W " Providers : ",$S('$O(IB("PRV",0)):IBU,1:"") 31 I $D(IB("PRV")) D ; at least 1 provider found 32 . N IBQ,A,A1,IBARR,IBTAX,IBNOTAX,IBSPEC,IBNOSPEC 33 . S IBZ=0 34 . D DEFSEC^IBCEF74(IBIFN,.IBARR) 35 . ; PRXM/KJH - Add Taxonomy code to display for patch 343. Moved secondary IDs slightly (below). 36 . S IBTAX=$$PROVTAX^IBCEF73A(IBIFN,.IBNOTAX) 37 . S IBSPEC=$$SPECTAX^IBCEF73A(IBIFN,.IBNOSPEC) 38 . F S IBZ=$O(IB("PRV",IBZ)) Q:'IBZ D 39 .. S IBQ="" 40 .. W !,?5,"- " 41 .. S A=$$EXPAND^IBTRE(399.0222,.01,IBZ) 42 .. I $P($G(IB("PRV",IBZ,1)),U,4)'="" S A1=" ("_$E($P(IB("PRV",IBZ,1),U,4),1,3)_")",A=$E(A,1,16-$L(A1))_A1 43 .. W $E(A_$J("",16),1,16),": " 44 .. I '$P($G(IB("PRV",IBZ,1)),U,3),$P($G(IB("PRV",IBZ,1)),U)="" W IBU Q 45 .. I $P($G(IB("PRV",IBZ,1)),U)'="" W:'$G(IB("PRV",IBZ)) $E($P(IB("PRV",IBZ,1),U)_$J("",16),1,16) W:$G(IB("PRV",IBZ)) "(OLD BOX 31 DATA) "_$P(IB("PRV",IBZ,1),U) 46 .. I $P($G(IB("PRV",IBZ,1)),U)="",$P($G(IB("PRV",IBZ)),U)'="" W $E($P(IB("PRV",IBZ),U)_$J("",16),1,16) 47 .. W " Taxonomy: ",$S($P(IBTAX,U,IBZ)'="":$P(IBTAX,U,IBZ),1:IBU),$S($P(IBSPEC,U,IBZ)'="":" ("_$P(IBSPEC,U,IBZ)_")",1:"") 48 .. F A=1:1:3 I $G(IBARR(IBZ,A))'="" S IBQ=IBQ_"["_$E("PST",A)_"]"_IBARR(IBZ,A)_" " 49 .. I $L(IBQ) W !,?30,$E(IBQ,1,49) 50 ; 51 K IB("PRV") 52 ; 53 S Z=4,IBW=1 X IBWW 54 W " Other Facility (VA/non): " S IBZ=$$EXPAND^IBTRE(399,232,+$P(IB("U2"),U,10)) 55 W $S(IBZ'="":$E(IBZ,1,23),$$PSRV^IBCEU(IBIFN):IBU,1:IBUN) 56 I IBZ'="" D 57 . ; PRXM/KJH - Add Taxonomy code to display for patch 343. 58 . W ?53,"Taxonomy: " 59 . S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,3),"X12 CODE") W $S(IBZ'="":IBZ,1:IBU) 60 . S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,3),"SPECIALTY CODE") W $S(IBZ'="":" ("_IBZ_")",1:"") 61 . Q 62 ; 63 ; clia# display - IB patch 320 64 S (IBZ,IBZ1)=$P(IB("U2"),U,13) ; retrieve CLIA# from database 65 ; 66 I IBZ="" D 67 . NEW CLIAREQ,DEFCLIA,DIE,DA,DR 68 . S CLIAREQ=$$CLIAREQ^IBCEP8A(IBIFN) 69 . I 'CLIAREQ S IBZ1=IBUN Q ; clia# not needed 70 . S DEFCLIA=$$CLIA^IBCEP8A(IBIFN) ; default clia# for claim 71 . I DEFCLIA="" S IBZ1=IBU Q ; no default found 72 . I $G(IBMDOTCN) K IBMDOTCN S IBZ1=IBU Q ; user @-deleted clia# 73 . S IBZ1=DEFCLIA ; display and stuff default clia# 74 . S DIE=399,DA=IBIFN,DR="235///"_DEFCLIA D ^DIE ; stuff in default 75 . Q 76 ; 77 W !,?4,"Lab CLIA # : ",IBZ1 78 ; 79 ; Mammo# display IB patch 320 80 S (IBZ,IBZ1)=$P(IB("U3"),U,1) ; retrieve mammo# from database 81 ; 82 ; If mammo# is there, but should not be, then blank it out 83 I IBZ'="",'$$XRAY^IBCEP8A(IBIFN) D 84 . NEW DIE,DA,DR 85 . S IBZ1=IBUN ; mammo# not needed 86 . S DIE=399,DA=IBIFN,DR="242////@" D ^DIE 87 . Q 88 ; 89 I IBZ="" S IBZ1=IBUN 90 W !?4,"Mammography Cert # : ",IBZ1 91 ; 92 S Z=5,IBW=1 X IBWW 93 W " Chiropractic Data : " S Y=$P(IB("U3"),U,5) X ^DD("DD") W $S(Y'="":"INITIAL TREATMENT ON "_Y,1:IBUN) 94 ; 95 S Z=6,IBW=1 X IBWW 96 W " Form Locator 19 : " S IBZ=$P($G(^DGCR(399,IBIFN,"UF31")),U,3) W $S(IBZ'="":IBZ,1:IBUN) 97 I $P(IB("U2"),U,14)'="" W !,?4,"Homebound : ",$$EXPAND^IBTRE(399,236,$P(IB("U2"),U,14)) 98 I $P(IB("U2"),U,15)'="" W !,?4,"Date Last Seen : ",$$EXPAND^IBTRE(399,237,$P(IB("U2"),U,15)) 99 I $P(IB("U2"),U,16)'="" W !,?4,"Spec Prog Indicator: " S IBZ=$$EXPAND^IBTRE(399,238,$P(IB("U2"),U,16)) W $S(IBZ'="":IBZ,$$WNRBILL^IBEFUNC(IBIFN):"31",1:"") 100 ; 101 S Z=7,IBW=1 X IBWW 102 S IBREQ=+$$REQMRA^IBEFUNC(IBIFN) S:IBREQ IBREQ=1 103 S IBMRASEC=$$MRASEC^IBCEF4(IBIFN) 104 W " ",$S('IBREQ:"Force To Print? : ",1:"Force MRA Sec Prt? : ") 105 S IBZ=$$EXTERNAL^DILFD(399,27+IBREQ,,+$P(IB("TX"),U,8+IBREQ)) 106 I IBMRASEC,'$P(IB("TX"),U,8),$P(IB("TX"),U,9) S IBZ="FORCED TO PRINT BY MRA PRIMARY",$P(IB("TX"),U,8)=0 107 W $S(IBZ'=""&($P(IB("TX"),U,8+IBREQ)'=""):IBZ,'$$TXMT^IBCEF4(IBIFN):"[NOT APPLICABLE - NOT TRANSMITTABLE]",IBREQ:"NO FORCED PRINT",1:IBZ) 108 ; 109 S Z=8,IBW=1 X IBWW 110 W " Provider ID Maint : (Edit Provider ID information)",! 111 G ^IBCSCP 112 Q Q 113 ; 114 WRT1(IBCRED) ; Write credentials mismatch 115 W !,*7," **Warning** Credentials differ from those found in NEW PERSON or IB NON VA",!,$J("",14),"BILLING PROVIDER file (",$S(IBCRED="":"none",1:IBCRED),")" 116 W !,$J("",14),"Changes will print local, but only credentials on file transmit" 117 Q 118 ; 119 NSAME(DA) ; Returns 1 if div on bill is not the default billing facility 120 Q ($P($G(^IBE(350.9,1,0)),U,2)'=$P($G(^DG(40.8,+$P(^DGCR(399,DA,0),U,22),0)),U,7)) 121 ; 122 ;IBCSC8H 1 IBCSC8H ;ALB/ARH - MCCR SCREEN 8 (BILL SPECIFIC INFO) CMS-1500 ;4/21/92 2 ;;2.0;INTEGRATED BILLING;**51,137,207,210,232,155,320,343,349**;21-MAR-94;Build 46 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; CMS-1500 screen 8 5 ; 6 ; MAP TO DGCRSC8H 7 ; 8 EN N I,IB,Y,Z 9 D ^IBCSCU S IBSR=8,IBSR1="H",IBV1="0000000" S:IBV IBV1="1111111" F I="U","U1","UF2","UF3","U2","M","TX",0,"U3" S IB(I)=$G(^DGCR(399,IBIFN,I)) 10 N IBZ,IBPRV,IBDATE,IBREQ,IBMRASEC,IBZ1 11 ; 12 S IBDATE=$$BDATE^IBACSV(IBIFN) ; Date of service for the bill 13 S IBPRV="" 14 D GETPRV^IBCEU(IBIFN,"ALL",.IBPRV) 15 K IB("PRV") 16 S IBZ=0 F S IBZ=$O(IBPRV(IBZ)) Q:'IBZ I $O(IBPRV(IBZ,0))!$D(IBPRV(IBZ,"NOTOPT")) M IB("PRV",IBZ)=IBPRV(IBZ) 17 ; 18 D H^IBCSCU 19 S Z=1,IBW=1 X IBWW W " Unable To Work From: " S Y=$P(IB("U"),U,16) X ^DD("DD") W $S(Y'="":Y,1:IBUN) 20 W !?4,"Unable To Work To : " S Y=$P(IB("U"),U,17) X ^DD("DD") W $S(Y'="":Y,1:IBUN) 21 S Z=2,IBW=1 X IBWW W " Admitting Dx : " S IBZ=$$ICD9^IBACSV(+IB("U2"),IBDATE) W $S(IBZ'="":$P(IBZ,U)_" - "_$P(IBZ,U,3),1:IBUN) 22 S IBZ="",IBZ=$S($P(IB("UF3"),U,4)]"":"Pri: "_$P(IB("UF3"),U,4),1:"")_$S($P(IB("UF3"),U,5)'="":" Sec: "_$P(IB("UF3"),U,5),1:"")_$S($P(IB("UF3"),U,6)'="":" Ter: "_$P(IB("UF3"),U,6),1:"") 23 S:IBZ="" IBZ=IBUN 24 W !,?4,"ICN/DCN(s) : ",IBZ 25 S IBZ=$$CKPROV^IBCEU(IBIFN,3) 26 S IBZ="",IBZ=$S($P(IB("U"),U,13)]"":"Pri: "_$P(IB("U"),U,13),1:"")_$S($P(IB("U2"),U,8)'="":" Sec: "_$P(IB("U2"),U,8),1:"")_$S($P(IB("U2"),U,9)'="":" Ter: "_$P(IB("U2"),U,9),1:"") 27 S:IBZ="" IBZ=IBUN 28 W !?4,"Tx Auth. Code(s) : ",IBZ 29 S Z=3,IBW=1 X IBWW 30 W " Providers : ",$S('$O(IB("PRV",0)):IBU,1:"") 31 I $D(IB("PRV")) D ; at least 1 provider found 32 . N IBQ,A,A1,IBARR,IBTAX,IBNOTAX,IBSPEC,IBNOSPEC 33 . S IBZ=0 34 . D DEFSEC^IBCEF74(IBIFN,.IBARR) 35 . ; PRXM/KJH - Add Taxonomy code to display for patch 343. Moved secondary IDs slightly (below). 36 . S IBTAX=$$PROVTAX^IBCEF73A(IBIFN,.IBNOTAX) 37 . S IBSPEC=$$SPECTAX^IBCEF73A(IBIFN,.IBNOSPEC) 38 . F S IBZ=$O(IB("PRV",IBZ)) Q:'IBZ D 39 .. S IBQ="" 40 .. W !,?5,"- " 41 .. S A=$$EXPAND^IBTRE(399.0222,.01,IBZ) 42 .. I $P($G(IB("PRV",IBZ,1)),U,4)'="" S A1=" ("_$E($P(IB("PRV",IBZ,1),U,4),1,3)_")",A=$E(A,1,16-$L(A1))_A1 43 .. W $E(A_$J("",16),1,16),": " 44 .. I '$P($G(IB("PRV",IBZ,1)),U,3),$P($G(IB("PRV",IBZ,1)),U)="" W IBU Q 45 .. I $P($G(IB("PRV",IBZ,1)),U)'="" W:'$G(IB("PRV",IBZ)) $E($P(IB("PRV",IBZ,1),U)_$J("",16),1,16) W:$G(IB("PRV",IBZ)) "(OLD BOX 31 DATA) "_$P(IB("PRV",IBZ,1),U) 46 .. I $P($G(IB("PRV",IBZ,1)),U)="",$P($G(IB("PRV",IBZ)),U)'="" W $E($P(IB("PRV",IBZ),U)_$J("",16),1,16) 47 .. W " Taxonomy: ",$S($P(IBTAX,U,IBZ)'="":$P(IBTAX,U,IBZ),1:IBU),$S($P(IBSPEC,U,IBZ)'="":" ("_$P(IBSPEC,U,IBZ)_")",1:"") 48 .. F A=1:1:3 I $G(IBARR(IBZ,A))'="" S IBQ=IBQ_"["_$E("PST",A)_"]"_IBARR(IBZ,A)_" " 49 .. I $L(IBQ) W !,?30,$E(IBQ,1,49) 50 ; 51 K IB("PRV") 52 ; 53 S Z=4,IBW=1 X IBWW 54 W " Other Facility (VA/non): " S IBZ=$$EXPAND^IBTRE(399,232,+$P(IB("U2"),U,10)) 55 W $S(IBZ'="":$E(IBZ,1,23),$$PSRV^IBCEU(IBIFN):IBU,1:IBUN) 56 I IBZ'="" D 57 . ; PRXM/KJH - Add Taxonomy code to display for patch 343. 58 . W ?53,"Taxonomy: " 59 . S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,3),"X12 CODE") W $S(IBZ'="":IBZ,1:IBU) 60 . S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,3),"SPECIALTY CODE") W $S(IBZ'="":" ("_IBZ_")",1:"") 61 . Q 62 ; 63 ; clia# display - IB patch 320 64 S (IBZ,IBZ1)=$P(IB("U2"),U,13) ; retrieve CLIA# from database 65 ; 66 I IBZ="" D 67 . NEW CLIAREQ,DEFCLIA,DIE,DA,DR 68 . S CLIAREQ=$$CLIAREQ^IBCEP8A(IBIFN) 69 . I 'CLIAREQ S IBZ1=IBUN Q ; clia# not needed 70 . S DEFCLIA=$$CLIA^IBCEP8A(IBIFN) ; default clia# for claim 71 . I DEFCLIA="" S IBZ1=IBU Q ; no default found 72 . I $G(IBMDOTCN) K IBMDOTCN S IBZ1=IBU Q ; user @-deleted clia# 73 . S IBZ1=DEFCLIA ; display and stuff default clia# 74 . S DIE=399,DA=IBIFN,DR="235///"_DEFCLIA D ^DIE ; stuff in default 75 . Q 76 ; 77 W !,?4,"Lab CLIA # : ",IBZ1 78 ; 79 ; Mammo# display IB patch 320 80 S (IBZ,IBZ1)=$P(IB("U3"),U,1) ; retrieve mammo# from database 81 ; 82 ; If mammo# is there, but should not be, then blank it out 83 I IBZ'="",'$$XRAY^IBCEP8A(IBIFN) D 84 . NEW DIE,DA,DR 85 . S IBZ1=IBUN ; mammo# not needed 86 . S DIE=399,DA=IBIFN,DR="242////@" D ^DIE 87 . Q 88 ; 89 I IBZ="" S IBZ1=IBUN 90 W !?4,"Mammography Cert # : ",IBZ1 91 ; 92 S Z=5,IBW=1 X IBWW 93 W " Form Locator 19 : " S IBZ=$P($G(^DGCR(399,IBIFN,"UF31")),U,3) W $S(IBZ'="":IBZ,1:IBUN) 94 I $P(IB("U2"),U,14)'="" W !,?4,"Homebound : ",$$EXPAND^IBTRE(399,236,$P(IB("U2"),U,14)) 95 I $P(IB("U2"),U,15)'="" W !,?4,"Date Last Seen : ",$$EXPAND^IBTRE(399,237,$P(IB("U2"),U,15)) 96 I $P(IB("U2"),U,16)'="" W !,?4,"Spec Prog Indicator: " S IBZ=$$EXPAND^IBTRE(399,238,$P(IB("U2"),U,16)) W $S(IBZ'="":IBZ,$$WNRBILL^IBEFUNC(IBIFN):"31",1:"") 97 ; 98 S Z=6,IBW=1 X IBWW 99 S IBREQ=+$$REQMRA^IBEFUNC(IBIFN) S:IBREQ IBREQ=1 100 S IBMRASEC=$$MRASEC^IBCEF4(IBIFN) 101 W " ",$S('IBREQ:"Force To Print? : ",1:"Force MRA Sec Prt? : ") 102 S IBZ=$$EXTERNAL^DILFD(399,27+IBREQ,,+$P(IB("TX"),U,8+IBREQ)) 103 I IBMRASEC,'$P(IB("TX"),U,8),$P(IB("TX"),U,9) S IBZ="FORCED TO PRINT BY MRA PRIMARY",$P(IB("TX"),U,8)=0 104 W $S(IBZ'=""&($P(IB("TX"),U,8+IBREQ)'=""):IBZ,'$$TXMT^IBCEF4(IBIFN):"[NOT APPLICABLE - NOT TRANSMITTABLE]",IBREQ:"NO FORCED PRINT",1:IBZ) 105 ; 106 S Z=7,IBW=1 X IBWW 107 W " Provider ID Maint : (Edit Provider ID information)",! 108 G ^IBCSCP 109 Q Q 110 ; 111 WRT1(IBCRED) ; Write credentials mismatch 112 W !,*7," **Warning** Credentials differ from those found in NEW PERSON or IB NON VA",!,$J("",14),"BILLING PROVIDER file (",$S(IBCRED="":"none",1:IBCRED),")" 113 W !,$J("",14),"Changes will print local, but only credentials on file transmit" 114 Q 115 ; 116 NSAME(DA) ; Returns 1 if div on bill is not the default billing facility 117 Q ($P($G(^IBE(350.9,1,0)),U,2)'=$P($G(^DG(40.8,+$P(^DGCR(399,DA,0),U,22),0)),U,7)) 118 ; 119 ;IBCSC8H
Note:
See TracChangeset
for help on using the changeset viewer.
