Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCSC10H

IBCSC10H.m

Go to the documentation of this file.
  1. IBCSC10H ;ALB/ARH - MCCR SCREEN 10 (BILL SPECIFIC INFO) CMS-1500 ;4/21/92
  1. ;;2.0;INTEGRATED BILLING;**432,488,547,592,759**;21-MAR-94;Build 24
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ; CMS-1500 screen 10
  1. ;
  1. ; MAP TO DGCRSC8H
  1. ;
  1. ; DEM;432 - Moved IBCSC8* billing screen routines to IBCSC10* billing screen
  1. ; routines and created a new billing screen 8 routine IBCSC8.
  1. ;
  1. EN ;
  1. N I,IB,Y,Z
  1. D ^IBCSCU
  1. ;
  1. ;WCJ;IB*2.0*547
  1. ;S IBSR=10,IBSR1="H",IBV1="000000000" S:IBV IBV1="111111111"
  1. ;
  1. ;S IBSR=10,IBSR1="H",IBV1="0000000000" S:IBV IBV1="1111111111"
  1. S IBSR=10,IBSR1="H",IBV1="0000000000" ; all sections editable on screen
  1. S:'+$$BBB^IBCSC10(IBIFN) $E(IBV1,8)=1 ;WCJ;IB759; make undeditable if not set up for payer
  1. S:IBV IBV1="1111111111" ; uneditable if view only
  1. ;
  1. ;JWS;IB*2.0*592 US1108 - Dental form 7
  1. I $$FT^IBCU3(IBIFN)=7 S IBV1="1001100010" S:IBV IBV1="11111111"
  1. ;F I="U","U1","UF2","UF3","UF32","U2","M","TX",0,"U3" S IB(I)=$G(^DGCR(399,IBIFN,I))
  1. F I="U","U1","UF2","UF3","UF32","U2","M","M2","TX",0,"U3" S IB(I)=$G(^DGCR(399,IBIFN,I))
  1. ;
  1. N IBZ,IBPRV,IBDATE,IBREQ,IBMRASEC,IBZ1,IBZCNT
  1. ;
  1. S IBDATE=$$BDATE^IBACSV(IBIFN) ; Date of service for the bill
  1. S IBPRV=""
  1. D GETPRV^IBCEU(IBIFN,"ALL",.IBPRV)
  1. K IB("PRV")
  1. 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)
  1. ;
  1. D H^IBCSCU
  1. ;
  1. ; Section 1
  1. 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)
  1. W !?4,"Unable To Work To : " S Y=$P(IB("U"),U,17) X ^DD("DD") W $S(Y'="":Y,1:IBUN)
  1. ;
  1. ; Section 2
  1. S Z=2,IBW=1
  1. X IBWW I $$INPAT^IBCEF(IBIFN) W " Admitting Dx : " S IBZ=$$ICD9^IBACSV(+IB("U2"),IBDATE) W $S(IBZ'="":$P(IBZ,U)_" - "_$P(IBZ,U,3),1:IBUN),!
  1. S IBZCNT=0,IBZ(IBZCNT)=""
  1. I $P(IB("UF3"),U,4)]"" S IBZ(IBZCNT)="P: "_$P(IB("UF3"),U,4),IBZCNT=IBZCNT+1
  1. I $P(IB("UF3"),U,5)]"" S IBZ(IBZCNT)="S: "_$P(IB("UF3"),U,5),IBZCNT=IBZCNT+1
  1. I $P(IB("UF3"),U,6)]"" S IBZ(IBZCNT)="T: "_$P(IB("UF3"),U,6)
  1. S:IBZ(0)="" IBZ(0)=IBUN
  1. W ?4,"ICN/DCN(s) : ",IBZ(0)
  1. F IBZCNT=1:1 Q:'$D(IBZ(IBZCNT)) W !?25,IBZ(IBZCNT)
  1. K IBZ
  1. S IBZ=$$CKPROV^IBCEU(IBIFN,3)
  1. S IBZCNT=0,IBZ(IBZCNT)=""
  1. I $P(IB("U"),U,13)]"" S IBZ(IBZCNT)="P: "_$P(IB("U"),U,13),IBZCNT=IBZCNT+1
  1. I $P(IB("U2"),U,8)'="" S IBZ(IBZCNT)="S: "_$P(IB("U2"),U,8),IBZCNT=IBZCNT+1
  1. I $P(IB("U2"),U,9)'="" S IBZ(IBZCNT)="T: "_$P(IB("U2"),U,9),IBZCNT=IBZCNT+1
  1. I $P(IB("UF32"),U,1)'="" S IBZ(IBZCNT)="P: "_$P(IB("UF32"),U,1),IBZCNT=IBZCNT+1
  1. I $P(IB("UF32"),U,2)'="" S IBZ(IBZCNT)="S: "_$P(IB("UF32"),U,2),IBZCNT=IBZCNT+1
  1. I $P(IB("UF32"),U,3)'="" S IBZ(IBZCNT)="T: "_$P(IB("UF32"),U,3)
  1. S:IBZ(0)="" IBZ(0)=IBUN
  1. W !,?3," Auth/Referral : ",IBZ(0)
  1. F IBZCNT=1:1 Q:'$D(IBZ(IBZCNT)) W !?25,IBZ(IBZCNT)
  1. K IBZ S IBZ=""
  1. ;
  1. ; Section 3
  1. S Z=3,IBW=1 X IBWW
  1. W " Providers : ",$S('$O(IB("PRV",0)):IBU,1:"")
  1. I $D(IB("PRV")) D ; at least 1 provider found
  1. . N IBQ,A,A1,IBARR,IBTAX,IBNOTAX,IBSPEC,IBNOSPEC
  1. . S IBZ=0
  1. . D DEFSEC^IBCEF74(IBIFN,.IBARR)
  1. . ; PRXM/KJH - Add Taxonomy code to display for patch 343. Moved secondary IDs slightly (below).
  1. . S IBTAX=$$PROVTAX^IBCEF73A(IBIFN,.IBNOTAX)
  1. . S IBSPEC=$$SPECTAX^IBCEF73A(IBIFN,.IBNOSPEC)
  1. . F S IBZ=$O(IB("PRV",IBZ)) Q:'IBZ D
  1. .. S IBQ=""
  1. .. W !,?5,"- "
  1. .. S A=$$EXPAND^IBTRE(399.0222,.01,IBZ)
  1. .. 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
  1. .. W $E(A_$J("",16),1,16),": "
  1. .. I '$P($G(IB("PRV",IBZ,1)),U,3),$P($G(IB("PRV",IBZ,1)),U)="" W IBU Q
  1. .. 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)
  1. .. 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)
  1. .. W " Taxonomy: ",$S($P(IBTAX,U,IBZ)'="":$P(IBTAX,U,IBZ),1:IBU),$S($P(IBSPEC,U,IBZ)'="":" ("_$P(IBSPEC,U,IBZ)_")",1:"")
  1. .. F A=1:1:3 I $G(IBARR(IBZ,A))'="" S IBQ=IBQ_"["_$E("PST",A)_"]"_IBARR(IBZ,A)_" "
  1. .. I $L(IBQ) W !,?30,$E(IBQ,1,49)
  1. ;
  1. K IB("PRV")
  1. ;
  1. ; Section 4
  1. S Z=4,IBW=1 X IBWW
  1. W " Other Facility (VA/non): " S IBZ=$$EXPAND^IBTRE(399,232,+$P(IB("U2"),U,10))
  1. W $S(IBZ'="":$E(IBZ,1,23),$$PSRV^IBCEU(IBIFN):IBU,1:IBUN)
  1. I IBZ'="" D
  1. . ; PRXM/KJH - Add Taxonomy code to display for patch 343.
  1. . W ?53,"Taxonomy: "
  1. . S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,3),"X12 CODE") W $S(IBZ'="":IBZ,1:IBU)
  1. . S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,3),"SPECIALTY CODE") W $S(IBZ'="":" ("_IBZ_")",1:"")
  1. . Q
  1. ;
  1. ; clia# display - IB patch 320
  1. S (IBZ,IBZ1)=$P(IB("U2"),U,13) ; retrieve CLIA# from database
  1. ;
  1. I IBZ="" D
  1. . NEW CLIAREQ,DEFCLIA,DIE,DA,DR
  1. . S CLIAREQ=$$CLIAREQ^IBCEP8A(IBIFN)
  1. . I 'CLIAREQ S IBZ1=IBUN Q ; clia# not needed
  1. . S DEFCLIA=$$CLIA^IBCEP8A(IBIFN) ; default clia# for claim
  1. . I DEFCLIA="" S IBZ1=IBU Q ; no default found
  1. . I $G(IBMDOTCN) K IBMDOTCN S IBZ1=IBU Q ; user @-deleted clia#
  1. . S IBZ1=DEFCLIA ; display and stuff default clia#
  1. . S DIE=399,DA=IBIFN,DR="235///"_DEFCLIA D ^DIE ; stuff in default
  1. . Q
  1. ;
  1. W !,?4,"Lab CLIA # : ",IBZ1
  1. ;
  1. ; Mammo# display IB patch 320
  1. S (IBZ,IBZ1)=$P(IB("U3"),U,1) ; retrieve mammo# from database
  1. ;
  1. ; If mammo# is there, but should not be, then blank it out
  1. I IBZ'="",'$$XRAY^IBCEP8A(IBIFN) D
  1. . NEW DIE,DA,DR
  1. . S IBZ1=IBUN ; mammo# not needed
  1. . S DIE=399,DA=IBIFN,DR="242////@" D ^DIE
  1. . Q
  1. ;
  1. I IBZ="" S IBZ1=IBUN
  1. W !?4,"Mammography Cert # : ",IBZ1
  1. ;
  1. ; Section 5
  1. S Z=5,IBW=1 X IBWW
  1. W " Chiropractic Data : " S Y=$P(IB("U3"),U,5) X ^DD("DD") W $S(Y'="":"INITIAL TREATMENT ON "_Y,1:IBUN)
  1. ;
  1. ; Section 6 -> changed prompt for *488* : baa
  1. S Z=6,IBW=1 X IBWW
  1. ;JWS;IB*2.0*592 US1108 - Dental
  1. ;IA# 3820
  1. I $$FT^IBCU3(IBIFN)'=7 W " CMS-1500 Box 19 : " S IBZ=$P($G(^DGCR(399,IBIFN,"UF31")),U,3) W $S(IBZ'="":IBZ,1:IBUN)
  1. E D
  1. . W " Dental Claim Note : " S IBZ=$$GET1^DIQ(399,IBIFN_",",97)
  1. . I IBZ="" W IBUN Q
  1. . N IBNOTE
  1. . S IBNOTE=$$WRAP(IBZ,53,53,.IBNOTE)
  1. . W $G(IBNOTE(1)) I $G(IBNOTE(2))'="" W !,?23,": ",IBNOTE(2)
  1. . Q
  1. ;end - JWS;IB*2.0*592 US1108 - Dental
  1. ;/ Beginning of IB*2.0*488 - Moved the following lines of code to IBCSC8 (vd)
  1. ;I $P(IB("U2"),U,14)'="" W !,?4,"Homebound : ",$$EXPAND^IBTRE(399,236,$P(IB("U2"),U,14))
  1. ;I $P(IB("U2"),U,15)'="" W !,?4,"Date Last Seen : ",$$EXPAND^IBTRE(399,237,$P(IB("U2"),U,15))
  1. ;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:"")
  1. ;/ End of IB*2.0*488 (vd)
  1. ;
  1. ; Section 7
  1. S Z=7,IBW=1 X IBWW
  1. W " Billing Provider : "
  1. K IBZ
  1. D GETBP^IBCEF79(IBIFN,"",+$$B^IBCEF79(IBIFN),"CMS-1500 SCREEN 8",.IBZ)
  1. S IBZ=$G(IBZ("CMS-1500 SCREEN 8","NAME"))
  1. W $S(IBZ'="":IBZ,1:IBU) ; billing provider name
  1. W !?3," Taxonomy Code : "
  1. S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,11),"X12 CODE") W $S(IBZ'="":IBZ,1:IBU)
  1. S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,11),"SPECIALTY CODE") W $S(IBZ'="":" ("_IBZ_")",1:"")
  1. ;
  1. ; Section 8
  1. ;WCJ;IB*2.0*547
  1. ;Adding ALT PRIMARY IDS and moving sections down to make room
  1. S Z=8,IBW=1 X IBWW
  1. W " Alt Prim Payer ID : "
  1. K IBZ
  1. S IBZCNT=0
  1. I $P(IB("M2"),U,2)]"" S IBZCNT=IBZCNT+1,IBZ(IBZCNT)="P: "_$P(IB("M2"),U,2)
  1. I $P(IB("M2"),U,4)]"" S IBZCNT=IBZCNT+1,IBZ(IBZCNT)="S: "_$P(IB("M2"),U,4)
  1. I $P(IB("M2"),U,6)]"" S IBZCNT=IBZCNT+1,IBZ(IBZCNT)="T: "_$P(IB("M2"),U,6)
  1. I 'IBZCNT W ?23,IBUN
  1. I IBZCNT F IBZ1=1:1:IBZCNT W ?23,IBZ(IBZ1) W:(IBZ1'=IBZCNT) !
  1. K IBZ
  1. ;
  1. ; Section 9
  1. S Z=9,IBW=1 X IBWW
  1. S IBREQ=+$$REQMRA^IBEFUNC(IBIFN) S:IBREQ IBREQ=1
  1. S IBMRASEC=$$MRASEC^IBCEF4(IBIFN)
  1. W " ",$S('IBREQ:"Force To Print? : ",1:"Force MRA Sec Prt? : ")
  1. S IBZ=$$EXTERNAL^DILFD(399,27+IBREQ,,+$P(IB("TX"),U,8+IBREQ))
  1. 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
  1. W $S(IBZ'=""&($P(IB("TX"),U,8+IBREQ)'=""):IBZ,'$$TXMT^IBCEF4(IBIFN):"[NOT APPLICABLE - NOT TRANSMITTABLE]",IBREQ:"NO FORCED PRINT",1:IBZ)
  1. ;
  1. ; Section 10
  1. S Z=10,IBW=1 X IBWW
  1. W " Provider ID Maint : (Edit Provider ID information)",!
  1. G ^IBCSCP
  1. Q Q
  1. ;
  1. WRT1(IBCRED) ; Write credentials mismatch
  1. 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),")"
  1. W !,$J("",14),"Changes will print local, but only credentials on file transmit"
  1. Q
  1. ;
  1. NSAME(DA) ; Returns 1 if div on bill is not the default billing facility
  1. 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))
  1. ;
  1. WRAP(STRING,ROOM,SUBS,IBARY) ; wrap long lines without breaking up words
  1. ;
  1. ; STRING = data string to wrap
  1. ; ROOM = number of characters to break at for line 1
  1. ; SUBS = number of characters to break at for subsequent lines (may or may not be same as ROOM)
  1. ; IBARY = (required) subscripted array to return wrapped data in:
  1. ; array(1)=first line
  1. ; array(2)= 2nd line and so on
  1. ;
  1. ; Returns total # of lines in description
  1. ;
  1. N START,END,I,C,STOP
  1. ; if there is enough room for 1 line, no wrapping needed
  1. I $L(STRING)'>ROOM S IBARY(1)=STRING Q 1
  1. I $F(STRING," ")=0 D Q 1
  1. . N LEN S LEN=$L(STRING)
  1. . F I=1:1 S IBARY(I)=$E(STRING,1,ROOM),STRING=$E(STRING,ROOM+1,LEN) Q:STRING=""
  1. . Q
  1. I $F(STRING," ")>ROOM S IBARY(1)=STRING Q 1
  1. ; add a space to the end of the string to avoid dropping last character
  1. S START=1,END=ROOM,STRING=STRING_" "
  1. F C=1:1 D Q:$L(STRING)<START Q:$G(STOP) ; stop if we have made it to the end of the data string
  1. .; start at the end and work backwards until you find a blank space, cut the line there and move on to the next line
  1. .F I=END:-1:1 I $E(STRING,I)=" " S IBARY(C)=$E(STRING,START,I),START=I+1,END=SUBS+START Q
  1. .I I=1 S STOP=1 I '$D(IBARY(1)) S IBARY(1)=STRING Q
  1. Q C
  1. ;
  1. ;JWS;IB*2.0*592;only allow either Rendering or Assistant Surgeon on a Dental Claim
  1. FILTERP(IBIEN,TYPE) ;filter input of provider for dental claims
  1. N OK,IBX1,IBX2
  1. S OK=1,IBX1=0
  1. F S IBX1=$O(^DGCR(399,IBIEN,"CP",IBX1)) Q:'IBX1 D Q:'OK
  1. . I TYPE=3,$D(^DGCR(399,IBIEN,"CP",IBX1,"LNPRV","B",6)) D I 'OK Q
  1. .. S IBX2=$O(^DGCR(399,IBIEN,"CP",IBX1,"LNPRV","B",6,0)) I IBX2="" Q
  1. .. I $P($G(^DGCR(399,IBIEN,"CP",IBX1,"LNPRV",IBX2,0)),"^",2)'="" S OK=0 Q
  1. . I TYPE=6,$D(^DGCR(399,IBIEN,"CP",IBX1,"LNPRV","B",3)) D I 'OK Q
  1. .. S IBX2=$O(^DGCR(399,IBIEN,"CP",IBX1,"LNPRV","B",3,0)) I IBX2="" Q
  1. .. I $P($G(^DGCR(399,IBIEN,"CP",IBX1,"LNPRV",IBX2,0)),"^",2)'="" S OK=0 Q
  1. I OK,TYPE=3,$D(^DGCR(399,IBIEN,"PRV","B",6)) D
  1. . S IBX1=$O(^DGCR(399,IBIEN,"PRV","B",6,0)) I IBX1="" Q
  1. . I $P($G(^DGCR(399,IBIEN,"PRV",IBX1,0)),"^",2)'="" S OK=0
  1. I OK,TYPE=6,$D(^DGCR(399,IBIEN,"PRV","B",3)) D
  1. . S IBX1=$O(^DGCR(399,IBIEN,"PRV","B",3,0)) I IBX1="" Q
  1. . I $P($G(^DGCR(399,IBIEN,"PRV",IBX1,0)),"^",2)'="" S OK=0
  1. Q OK
  1. ;
  1. ;IBCSC10H