- IBCSC10H ;ALB/ARH - MCCR SCREEN 10 (BILL SPECIFIC INFO) CMS-1500 ;4/21/92
- ;;2.0;INTEGRATED BILLING;**432,488,547,592,759**;21-MAR-94;Build 24
- ;;Per VA Directive 6402, this routine should not be modified.
- ; CMS-1500 screen 10
- ;
- ; MAP TO DGCRSC8H
- ;
- ; DEM;432 - Moved IBCSC8* billing screen routines to IBCSC10* billing screen
- ; routines and created a new billing screen 8 routine IBCSC8.
- ;
- EN ;
- N I,IB,Y,Z
- D ^IBCSCU
- ;
- ;WCJ;IB*2.0*547
- ;S IBSR=10,IBSR1="H",IBV1="000000000" S:IBV IBV1="111111111"
- ;
- ;S IBSR=10,IBSR1="H",IBV1="0000000000" S:IBV IBV1="1111111111"
- S IBSR=10,IBSR1="H",IBV1="0000000000" ; all sections editable on screen
- S:'+$$BBB^IBCSC10(IBIFN) $E(IBV1,8)=1 ;WCJ;IB759; make undeditable if not set up for payer
- S:IBV IBV1="1111111111" ; uneditable if view only
- ;
- ;JWS;IB*2.0*592 US1108 - Dental form 7
- I $$FT^IBCU3(IBIFN)=7 S IBV1="1001100010" S:IBV IBV1="11111111"
- ;F I="U","U1","UF2","UF3","UF32","U2","M","TX",0,"U3" S IB(I)=$G(^DGCR(399,IBIFN,I))
- F I="U","U1","UF2","UF3","UF32","U2","M","M2","TX",0,"U3" S IB(I)=$G(^DGCR(399,IBIFN,I))
- ;
- N IBZ,IBPRV,IBDATE,IBREQ,IBMRASEC,IBZ1,IBZCNT
- ;
- S IBDATE=$$BDATE^IBACSV(IBIFN) ; Date of service for the bill
- S IBPRV=""
- D GETPRV^IBCEU(IBIFN,"ALL",.IBPRV)
- K IB("PRV")
- 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)
- ;
- D H^IBCSCU
- ;
- ; Section 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)
- W !?4,"Unable To Work To : " S Y=$P(IB("U"),U,17) X ^DD("DD") W $S(Y'="":Y,1:IBUN)
- ;
- ; Section 2
- S Z=2,IBW=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),!
- S IBZCNT=0,IBZ(IBZCNT)=""
- I $P(IB("UF3"),U,4)]"" S IBZ(IBZCNT)="P: "_$P(IB("UF3"),U,4),IBZCNT=IBZCNT+1
- I $P(IB("UF3"),U,5)]"" S IBZ(IBZCNT)="S: "_$P(IB("UF3"),U,5),IBZCNT=IBZCNT+1
- I $P(IB("UF3"),U,6)]"" S IBZ(IBZCNT)="T: "_$P(IB("UF3"),U,6)
- S:IBZ(0)="" IBZ(0)=IBUN
- W ?4,"ICN/DCN(s) : ",IBZ(0)
- F IBZCNT=1:1 Q:'$D(IBZ(IBZCNT)) W !?25,IBZ(IBZCNT)
- K IBZ
- S IBZ=$$CKPROV^IBCEU(IBIFN,3)
- S IBZCNT=0,IBZ(IBZCNT)=""
- I $P(IB("U"),U,13)]"" S IBZ(IBZCNT)="P: "_$P(IB("U"),U,13),IBZCNT=IBZCNT+1
- I $P(IB("U2"),U,8)'="" S IBZ(IBZCNT)="S: "_$P(IB("U2"),U,8),IBZCNT=IBZCNT+1
- I $P(IB("U2"),U,9)'="" S IBZ(IBZCNT)="T: "_$P(IB("U2"),U,9),IBZCNT=IBZCNT+1
- I $P(IB("UF32"),U,1)'="" S IBZ(IBZCNT)="P: "_$P(IB("UF32"),U,1),IBZCNT=IBZCNT+1
- I $P(IB("UF32"),U,2)'="" S IBZ(IBZCNT)="S: "_$P(IB("UF32"),U,2),IBZCNT=IBZCNT+1
- I $P(IB("UF32"),U,3)'="" S IBZ(IBZCNT)="T: "_$P(IB("UF32"),U,3)
- S:IBZ(0)="" IBZ(0)=IBUN
- W !,?3," Auth/Referral : ",IBZ(0)
- F IBZCNT=1:1 Q:'$D(IBZ(IBZCNT)) W !?25,IBZ(IBZCNT)
- K IBZ S IBZ=""
- ;
- ; Section 3
- S Z=3,IBW=1 X IBWW
- W " Providers : ",$S('$O(IB("PRV",0)):IBU,1:"")
- I $D(IB("PRV")) D ; at least 1 provider found
- . N IBQ,A,A1,IBARR,IBTAX,IBNOTAX,IBSPEC,IBNOSPEC
- . S IBZ=0
- . D DEFSEC^IBCEF74(IBIFN,.IBARR)
- . ; PRXM/KJH - Add Taxonomy code to display for patch 343. Moved secondary IDs slightly (below).
- . S IBTAX=$$PROVTAX^IBCEF73A(IBIFN,.IBNOTAX)
- . S IBSPEC=$$SPECTAX^IBCEF73A(IBIFN,.IBNOSPEC)
- . F S IBZ=$O(IB("PRV",IBZ)) Q:'IBZ D
- .. S IBQ=""
- .. W !,?5,"- "
- .. S A=$$EXPAND^IBTRE(399.0222,.01,IBZ)
- .. 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
- .. W $E(A_$J("",16),1,16),": "
- .. I '$P($G(IB("PRV",IBZ,1)),U,3),$P($G(IB("PRV",IBZ,1)),U)="" W IBU Q
- .. 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)
- .. 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)
- .. W " Taxonomy: ",$S($P(IBTAX,U,IBZ)'="":$P(IBTAX,U,IBZ),1:IBU),$S($P(IBSPEC,U,IBZ)'="":" ("_$P(IBSPEC,U,IBZ)_")",1:"")
- .. F A=1:1:3 I $G(IBARR(IBZ,A))'="" S IBQ=IBQ_"["_$E("PST",A)_"]"_IBARR(IBZ,A)_" "
- .. I $L(IBQ) W !,?30,$E(IBQ,1,49)
- ;
- K IB("PRV")
- ;
- ; Section 4
- S Z=4,IBW=1 X IBWW
- W " Other Facility (VA/non): " S IBZ=$$EXPAND^IBTRE(399,232,+$P(IB("U2"),U,10))
- W $S(IBZ'="":$E(IBZ,1,23),$$PSRV^IBCEU(IBIFN):IBU,1:IBUN)
- I IBZ'="" D
- . ; PRXM/KJH - Add Taxonomy code to display for patch 343.
- . W ?53,"Taxonomy: "
- . S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,3),"X12 CODE") W $S(IBZ'="":IBZ,1:IBU)
- . S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,3),"SPECIALTY CODE") W $S(IBZ'="":" ("_IBZ_")",1:"")
- . Q
- ;
- ; clia# display - IB patch 320
- S (IBZ,IBZ1)=$P(IB("U2"),U,13) ; retrieve CLIA# from database
- ;
- I IBZ="" D
- . NEW CLIAREQ,DEFCLIA,DIE,DA,DR
- . S CLIAREQ=$$CLIAREQ^IBCEP8A(IBIFN)
- . I 'CLIAREQ S IBZ1=IBUN Q ; clia# not needed
- . S DEFCLIA=$$CLIA^IBCEP8A(IBIFN) ; default clia# for claim
- . I DEFCLIA="" S IBZ1=IBU Q ; no default found
- . I $G(IBMDOTCN) K IBMDOTCN S IBZ1=IBU Q ; user @-deleted clia#
- . S IBZ1=DEFCLIA ; display and stuff default clia#
- . S DIE=399,DA=IBIFN,DR="235///"_DEFCLIA D ^DIE ; stuff in default
- . Q
- ;
- W !,?4,"Lab CLIA # : ",IBZ1
- ;
- ; Mammo# display IB patch 320
- S (IBZ,IBZ1)=$P(IB("U3"),U,1) ; retrieve mammo# from database
- ;
- ; If mammo# is there, but should not be, then blank it out
- I IBZ'="",'$$XRAY^IBCEP8A(IBIFN) D
- . NEW DIE,DA,DR
- . S IBZ1=IBUN ; mammo# not needed
- . S DIE=399,DA=IBIFN,DR="242////@" D ^DIE
- . Q
- ;
- I IBZ="" S IBZ1=IBUN
- W !?4,"Mammography Cert # : ",IBZ1
- ;
- ; Section 5
- S Z=5,IBW=1 X IBWW
- W " Chiropractic Data : " S Y=$P(IB("U3"),U,5) X ^DD("DD") W $S(Y'="":"INITIAL TREATMENT ON "_Y,1:IBUN)
- ;
- ; Section 6 -> changed prompt for *488* : baa
- S Z=6,IBW=1 X IBWW
- ;JWS;IB*2.0*592 US1108 - Dental
- ;IA# 3820
- 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)
- E D
- . W " Dental Claim Note : " S IBZ=$$GET1^DIQ(399,IBIFN_",",97)
- . I IBZ="" W IBUN Q
- . N IBNOTE
- . S IBNOTE=$$WRAP(IBZ,53,53,.IBNOTE)
- . W $G(IBNOTE(1)) I $G(IBNOTE(2))'="" W !,?23,": ",IBNOTE(2)
- . Q
- ;end - JWS;IB*2.0*592 US1108 - Dental
- ;/ Beginning of IB*2.0*488 - Moved the following lines of code to IBCSC8 (vd)
- ;I $P(IB("U2"),U,14)'="" W !,?4,"Homebound : ",$$EXPAND^IBTRE(399,236,$P(IB("U2"),U,14))
- ;I $P(IB("U2"),U,15)'="" W !,?4,"Date Last Seen : ",$$EXPAND^IBTRE(399,237,$P(IB("U2"),U,15))
- ;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:"")
- ;/ End of IB*2.0*488 (vd)
- ;
- ; Section 7
- S Z=7,IBW=1 X IBWW
- W " Billing Provider : "
- K IBZ
- D GETBP^IBCEF79(IBIFN,"",+$$B^IBCEF79(IBIFN),"CMS-1500 SCREEN 8",.IBZ)
- S IBZ=$G(IBZ("CMS-1500 SCREEN 8","NAME"))
- W $S(IBZ'="":IBZ,1:IBU) ; billing provider name
- W !?3," Taxonomy Code : "
- S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,11),"X12 CODE") W $S(IBZ'="":IBZ,1:IBU)
- S IBZ=$$GET1^DIQ(8932.1,+$P(IB("U3"),U,11),"SPECIALTY CODE") W $S(IBZ'="":" ("_IBZ_")",1:"")
- ;
- ; Section 8
- ;WCJ;IB*2.0*547
- ;Adding ALT PRIMARY IDS and moving sections down to make room
- S Z=8,IBW=1 X IBWW
- W " Alt Prim Payer ID : "
- K IBZ
- S IBZCNT=0
- I $P(IB("M2"),U,2)]"" S IBZCNT=IBZCNT+1,IBZ(IBZCNT)="P: "_$P(IB("M2"),U,2)
- I $P(IB("M2"),U,4)]"" S IBZCNT=IBZCNT+1,IBZ(IBZCNT)="S: "_$P(IB("M2"),U,4)
- I $P(IB("M2"),U,6)]"" S IBZCNT=IBZCNT+1,IBZ(IBZCNT)="T: "_$P(IB("M2"),U,6)
- I 'IBZCNT W ?23,IBUN
- I IBZCNT F IBZ1=1:1:IBZCNT W ?23,IBZ(IBZ1) W:(IBZ1'=IBZCNT) !
- K IBZ
- ;
- ; Section 9
- S Z=9,IBW=1 X IBWW
- S IBREQ=+$$REQMRA^IBEFUNC(IBIFN) S:IBREQ IBREQ=1
- S IBMRASEC=$$MRASEC^IBCEF4(IBIFN)
- W " ",$S('IBREQ:"Force To Print? : ",1:"Force MRA Sec Prt? : ")
- S IBZ=$$EXTERNAL^DILFD(399,27+IBREQ,,+$P(IB("TX"),U,8+IBREQ))
- 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
- W $S(IBZ'=""&($P(IB("TX"),U,8+IBREQ)'=""):IBZ,'$$TXMT^IBCEF4(IBIFN):"[NOT APPLICABLE - NOT TRANSMITTABLE]",IBREQ:"NO FORCED PRINT",1:IBZ)
- ;
- ; Section 10
- S Z=10,IBW=1 X IBWW
- W " Provider ID Maint : (Edit Provider ID information)",!
- G ^IBCSCP
- Q Q
- ;
- WRT1(IBCRED) ; Write credentials mismatch
- 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),")"
- W !,$J("",14),"Changes will print local, but only credentials on file transmit"
- Q
- ;
- NSAME(DA) ; Returns 1 if div on bill is not the default billing facility
- 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))
- ;
- WRAP(STRING,ROOM,SUBS,IBARY) ; wrap long lines without breaking up words
- ;
- ; STRING = data string to wrap
- ; ROOM = number of characters to break at for line 1
- ; SUBS = number of characters to break at for subsequent lines (may or may not be same as ROOM)
- ; IBARY = (required) subscripted array to return wrapped data in:
- ; array(1)=first line
- ; array(2)= 2nd line and so on
- ;
- ; Returns total # of lines in description
- ;
- N START,END,I,C,STOP
- ; if there is enough room for 1 line, no wrapping needed
- I $L(STRING)'>ROOM S IBARY(1)=STRING Q 1
- I $F(STRING," ")=0 D Q 1
- . N LEN S LEN=$L(STRING)
- . F I=1:1 S IBARY(I)=$E(STRING,1,ROOM),STRING=$E(STRING,ROOM+1,LEN) Q:STRING=""
- . Q
- I $F(STRING," ")>ROOM S IBARY(1)=STRING Q 1
- ; add a space to the end of the string to avoid dropping last character
- S START=1,END=ROOM,STRING=STRING_" "
- 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
- .; start at the end and work backwards until you find a blank space, cut the line there and move on to the next line
- .F I=END:-1:1 I $E(STRING,I)=" " S IBARY(C)=$E(STRING,START,I),START=I+1,END=SUBS+START Q
- .I I=1 S STOP=1 I '$D(IBARY(1)) S IBARY(1)=STRING Q
- Q C
- ;
- ;JWS;IB*2.0*592;only allow either Rendering or Assistant Surgeon on a Dental Claim
- FILTERP(IBIEN,TYPE) ;filter input of provider for dental claims
- N OK,IBX1,IBX2
- S OK=1,IBX1=0
- F S IBX1=$O(^DGCR(399,IBIEN,"CP",IBX1)) Q:'IBX1 D Q:'OK
- . I TYPE=3,$D(^DGCR(399,IBIEN,"CP",IBX1,"LNPRV","B",6)) D I 'OK Q
- .. S IBX2=$O(^DGCR(399,IBIEN,"CP",IBX1,"LNPRV","B",6,0)) I IBX2="" Q
- .. I $P($G(^DGCR(399,IBIEN,"CP",IBX1,"LNPRV",IBX2,0)),"^",2)'="" S OK=0 Q
- . I TYPE=6,$D(^DGCR(399,IBIEN,"CP",IBX1,"LNPRV","B",3)) D I 'OK Q
- .. S IBX2=$O(^DGCR(399,IBIEN,"CP",IBX1,"LNPRV","B",3,0)) I IBX2="" Q
- .. I $P($G(^DGCR(399,IBIEN,"CP",IBX1,"LNPRV",IBX2,0)),"^",2)'="" S OK=0 Q
- I OK,TYPE=3,$D(^DGCR(399,IBIEN,"PRV","B",6)) D
- . S IBX1=$O(^DGCR(399,IBIEN,"PRV","B",6,0)) I IBX1="" Q
- . I $P($G(^DGCR(399,IBIEN,"PRV",IBX1,0)),"^",2)'="" S OK=0
- I OK,TYPE=6,$D(^DGCR(399,IBIEN,"PRV","B",3)) D
- . S IBX1=$O(^DGCR(399,IBIEN,"PRV","B",3,0)) I IBX1="" Q
- . I $P($G(^DGCR(399,IBIEN,"PRV",IBX1,0)),"^",2)'="" S OK=0
- Q OK
- ;
- ;IBCSC10H
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSC10H 11055 printed Jan 18, 2025@03:21:21 Page 2
- 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
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ; CMS-1500 screen 10
- +4 ;
- +5 ; MAP TO DGCRSC8H
- +6 ;
- +7 ; DEM;432 - Moved IBCSC8* billing screen routines to IBCSC10* billing screen
- +8 ; routines and created a new billing screen 8 routine IBCSC8.
- +9 ;
- EN ;
- +1 NEW I,IB,Y,Z
- +2 DO ^IBCSCU
- +3 ;
- +4 ;WCJ;IB*2.0*547
- +5 ;S IBSR=10,IBSR1="H",IBV1="000000000" S:IBV IBV1="111111111"
- +6 ;
- +7 ;S IBSR=10,IBSR1="H",IBV1="0000000000" S:IBV IBV1="1111111111"
- +8 ; all sections editable on screen
- SET IBSR=10
- SET IBSR1="H"
- SET IBV1="0000000000"
- +9 ;WCJ;IB759; make undeditable if not set up for payer
- if '+$$BBB^IBCSC10(IBIFN)
- SET $EXTRACT(IBV1,8)=1
- +10 ; uneditable if view only
- if IBV
- SET IBV1="1111111111"
- +11 ;
- +12 ;JWS;IB*2.0*592 US1108 - Dental form 7
- +13 IF $$FT^IBCU3(IBIFN)=7
- SET IBV1="1001100010"
- if IBV
- SET IBV1="11111111"
- +14 ;F I="U","U1","UF2","UF3","UF32","U2","M","TX",0,"U3" S IB(I)=$G(^DGCR(399,IBIFN,I))
- +15 FOR I="U","U1","UF2","UF3","UF32","U2","M","M2","TX",0,"U3"
- SET IB(I)=$GET(^DGCR(399,IBIFN,I))
- +16 ;
- +17 NEW IBZ,IBPRV,IBDATE,IBREQ,IBMRASEC,IBZ1,IBZCNT
- +18 ;
- +19 ; Date of service for the bill
- SET IBDATE=$$BDATE^IBACSV(IBIFN)
- +20 SET IBPRV=""
- +21 DO GETPRV^IBCEU(IBIFN,"ALL",.IBPRV)
- +22 KILL IB("PRV")
- +23 SET IBZ=0
- FOR
- SET IBZ=$ORDER(IBPRV(IBZ))
- if 'IBZ
- QUIT
- IF $ORDER(IBPRV(IBZ,0))!$DATA(IBPRV(IBZ,"NOTOPT"))
- MERGE IB("PRV",IBZ)=IBPRV(IBZ)
- +24 ;
- +25 DO H^IBCSCU
- +26 ;
- +27 ; Section 1
- +28 SET Z=1
- SET IBW=1
- XECUTE IBWW
- WRITE " Unable To Work From: "
- SET Y=$PIECE(IB("U"),U,16)
- XECUTE ^DD("DD")
- WRITE $SELECT(Y'="":Y,1:IBUN)
- +29 WRITE !?4,"Unable To Work To : "
- SET Y=$PIECE(IB("U"),U,17)
- XECUTE ^DD("DD")
- WRITE $SELECT(Y'="":Y,1:IBUN)
- +30 ;
- +31 ; Section 2
- +32 SET Z=2
- SET IBW=1
- +33 XECUTE IBWW
- IF $$INPAT^IBCEF(IBIFN)
- WRITE " Admitting Dx : "
- SET IBZ=$$ICD9^IBACSV(+IB("U2"),IBDATE)
- WRITE $SELECT(IBZ'="":$PIECE(IBZ,U)_" - "_$PIECE(IBZ,U,3),1:IBUN),!
- +34 SET IBZCNT=0
- SET IBZ(IBZCNT)=""
- +35 IF $PIECE(IB("UF3"),U,4)]""
- SET IBZ(IBZCNT)="P: "_$PIECE(IB("UF3"),U,4)
- SET IBZCNT=IBZCNT+1
- +36 IF $PIECE(IB("UF3"),U,5)]""
- SET IBZ(IBZCNT)="S: "_$PIECE(IB("UF3"),U,5)
- SET IBZCNT=IBZCNT+1
- +37 IF $PIECE(IB("UF3"),U,6)]""
- SET IBZ(IBZCNT)="T: "_$PIECE(IB("UF3"),U,6)
- +38 if IBZ(0)=""
- SET IBZ(0)=IBUN
- +39 WRITE ?4,"ICN/DCN(s) : ",IBZ(0)
- +40 FOR IBZCNT=1:1
- if '$DATA(IBZ(IBZCNT))
- QUIT
- WRITE !?25,IBZ(IBZCNT)
- +41 KILL IBZ
- +42 SET IBZ=$$CKPROV^IBCEU(IBIFN,3)
- +43 SET IBZCNT=0
- SET IBZ(IBZCNT)=""
- +44 IF $PIECE(IB("U"),U,13)]""
- SET IBZ(IBZCNT)="P: "_$PIECE(IB("U"),U,13)
- SET IBZCNT=IBZCNT+1
- +45 IF $PIECE(IB("U2"),U,8)'=""
- SET IBZ(IBZCNT)="S: "_$PIECE(IB("U2"),U,8)
- SET IBZCNT=IBZCNT+1
- +46 IF $PIECE(IB("U2"),U,9)'=""
- SET IBZ(IBZCNT)="T: "_$PIECE(IB("U2"),U,9)
- SET IBZCNT=IBZCNT+1
- +47 IF $PIECE(IB("UF32"),U,1)'=""
- SET IBZ(IBZCNT)="P: "_$PIECE(IB("UF32"),U,1)
- SET IBZCNT=IBZCNT+1
- +48 IF $PIECE(IB("UF32"),U,2)'=""
- SET IBZ(IBZCNT)="S: "_$PIECE(IB("UF32"),U,2)
- SET IBZCNT=IBZCNT+1
- +49 IF $PIECE(IB("UF32"),U,3)'=""
- SET IBZ(IBZCNT)="T: "_$PIECE(IB("UF32"),U,3)
- +50 if IBZ(0)=""
- SET IBZ(0)=IBUN
- +51 WRITE !,?3," Auth/Referral : ",IBZ(0)
- +52 FOR IBZCNT=1:1
- if '$DATA(IBZ(IBZCNT))
- QUIT
- WRITE !?25,IBZ(IBZCNT)
- +53 KILL IBZ
- SET IBZ=""
- +54 ;
- +55 ; Section 3
- +56 SET Z=3
- SET IBW=1
- XECUTE IBWW
- +57 WRITE " Providers : ",$SELECT('$ORDER(IB("PRV",0)):IBU,1:"")
- +58 ; at least 1 provider found
- IF $DATA(IB("PRV"))
- Begin DoDot:1
- +59 NEW IBQ,A,A1,IBARR,IBTAX,IBNOTAX,IBSPEC,IBNOSPEC
- +60 SET IBZ=0
- +61 DO DEFSEC^IBCEF74(IBIFN,.IBARR)
- +62 ; PRXM/KJH - Add Taxonomy code to display for patch 343. Moved secondary IDs slightly (below).
- +63 SET IBTAX=$$PROVTAX^IBCEF73A(IBIFN,.IBNOTAX)
- +64 SET IBSPEC=$$SPECTAX^IBCEF73A(IBIFN,.IBNOSPEC)
- +65 FOR
- SET IBZ=$ORDER(IB("PRV",IBZ))
- if 'IBZ
- QUIT
- Begin DoDot:2
- +66 SET IBQ=""
- +67 WRITE !,?5,"- "
- +68 SET A=$$EXPAND^IBTRE(399.0222,.01,IBZ)
- +69 IF $PIECE($GET(IB("PRV",IBZ,1)),U,4)'=""
- SET A1=" ("_$EXTRACT($PIECE(IB("PRV",IBZ,1),U,4),1,3)_")"
- SET A=$EXTRACT(A,1,16-$LENGTH(A1))_A1
- +70 WRITE $EXTRACT(A_$JUSTIFY("",16),1,16),": "
- +71 IF '$PIECE($GET(IB("PRV",IBZ,1)),U,3)
- IF $PIECE($GET(IB("PRV",IBZ,1)),U)=""
- WRITE IBU
- QUIT
- +72 IF $PIECE($GET(IB("PRV",IBZ,1)),U)'=""
- if '$GET(IB("PRV",IBZ))
- WRITE $EXTRACT($PIECE(IB("PRV",IBZ,1),U)_$JUSTIFY("",16),1,16)
- if $GET(IB("PRV",IBZ))
- WRITE "(OLD BOX 31 DATA) "_$PIECE(IB("PRV",IBZ,1),U)
- +73 IF $PIECE($GET(IB("PRV",IBZ,1)),U)=""
- IF $PIECE($GET(IB("PRV",IBZ)),U)'=""
- WRITE $EXTRACT($PIECE(IB("PRV",IBZ),U)_$JUSTIFY("",16),1,16)
- +74 WRITE " Taxonomy: ",$SELECT($PIECE(IBTAX,U,IBZ)'="":$PIECE(IBTAX,U,IBZ),1:IBU),$SELECT($PIECE(IBSPEC,U,IBZ)'="":" ("_$PIECE(IBSPEC,U,IBZ)_")",1:"")
- +75 FOR A=1:1:3
- IF $GET(IBARR(IBZ,A))'=""
- SET IBQ=IBQ_"["_$EXTRACT("PST",A)_"]"_IBARR(IBZ,A)_" "
- +76 IF $LENGTH(IBQ)
- WRITE !,?30,$EXTRACT(IBQ,1,49)
- End DoDot:2
- End DoDot:1
- +77 ;
- +78 KILL IB("PRV")
- +79 ;
- +80 ; Section 4
- +81 SET Z=4
- SET IBW=1
- XECUTE IBWW
- +82 WRITE " Other Facility (VA/non): "
- SET IBZ=$$EXPAND^IBTRE(399,232,+$PIECE(IB("U2"),U,10))
- +83 WRITE $SELECT(IBZ'="":$EXTRACT(IBZ,1,23),$$PSRV^IBCEU(IBIFN):IBU,1:IBUN)
- +84 IF IBZ'=""
- Begin DoDot:1
- +85 ; PRXM/KJH - Add Taxonomy code to display for patch 343.
- +86 WRITE ?53,"Taxonomy: "
- +87 SET IBZ=$$GET1^DIQ(8932.1,+$PIECE(IB("U3"),U,3),"X12 CODE")
- WRITE $SELECT(IBZ'="":IBZ,1:IBU)
- +88 SET IBZ=$$GET1^DIQ(8932.1,+$PIECE(IB("U3"),U,3),"SPECIALTY CODE")
- WRITE $SELECT(IBZ'="":" ("_IBZ_")",1:"")
- +89 QUIT
- End DoDot:1
- +90 ;
- +91 ; clia# display - IB patch 320
- +92 ; retrieve CLIA# from database
- SET (IBZ,IBZ1)=$PIECE(IB("U2"),U,13)
- +93 ;
- +94 IF IBZ=""
- Begin DoDot:1
- +95 NEW CLIAREQ,DEFCLIA,DIE,DA,DR
- +96 SET CLIAREQ=$$CLIAREQ^IBCEP8A(IBIFN)
- +97 ; clia# not needed
- IF 'CLIAREQ
- SET IBZ1=IBUN
- QUIT
- +98 ; default clia# for claim
- SET DEFCLIA=$$CLIA^IBCEP8A(IBIFN)
- +99 ; no default found
- IF DEFCLIA=""
- SET IBZ1=IBU
- QUIT
- +100 ; user @-deleted clia#
- IF $GET(IBMDOTCN)
- KILL IBMDOTCN
- SET IBZ1=IBU
- QUIT
- +101 ; display and stuff default clia#
- SET IBZ1=DEFCLIA
- +102 ; stuff in default
- SET DIE=399
- SET DA=IBIFN
- SET DR="235///"_DEFCLIA
- DO ^DIE
- +103 QUIT
- End DoDot:1
- +104 ;
- +105 WRITE !,?4,"Lab CLIA # : ",IBZ1
- +106 ;
- +107 ; Mammo# display IB patch 320
- +108 ; retrieve mammo# from database
- SET (IBZ,IBZ1)=$PIECE(IB("U3"),U,1)
- +109 ;
- +110 ; If mammo# is there, but should not be, then blank it out
- +111 IF IBZ'=""
- IF '$$XRAY^IBCEP8A(IBIFN)
- Begin DoDot:1
- +112 NEW DIE,DA,DR
- +113 ; mammo# not needed
- SET IBZ1=IBUN
- +114 SET DIE=399
- SET DA=IBIFN
- SET DR="242////@"
- DO ^DIE
- +115 QUIT
- End DoDot:1
- +116 ;
- +117 IF IBZ=""
- SET IBZ1=IBUN
- +118 WRITE !?4,"Mammography Cert # : ",IBZ1
- +119 ;
- +120 ; Section 5
- +121 SET Z=5
- SET IBW=1
- XECUTE IBWW
- +122 WRITE " Chiropractic Data : "
- SET Y=$PIECE(IB("U3"),U,5)
- XECUTE ^DD("DD")
- WRITE $SELECT(Y'="":"INITIAL TREATMENT ON "_Y,1:IBUN)
- +123 ;
- +124 ; Section 6 -> changed prompt for *488* : baa
- +125 SET Z=6
- SET IBW=1
- XECUTE IBWW
- +126 ;JWS;IB*2.0*592 US1108 - Dental
- +127 ;IA# 3820
- +128 IF $$FT^IBCU3(IBIFN)'=7
- WRITE " CMS-1500 Box 19 : "
- SET IBZ=$PIECE($GET(^DGCR(399,IBIFN,"UF31")),U,3)
- WRITE $SELECT(IBZ'="":IBZ,1:IBUN)
- +129 IF '$TEST
- Begin DoDot:1
- +130 WRITE " Dental Claim Note : "
- SET IBZ=$$GET1^DIQ(399,IBIFN_",",97)
- +131 IF IBZ=""
- WRITE IBUN
- QUIT
- +132 NEW IBNOTE
- +133 SET IBNOTE=$$WRAP(IBZ,53,53,.IBNOTE)
- +134 WRITE $GET(IBNOTE(1))
- IF $GET(IBNOTE(2))'=""
- WRITE !,?23,": ",IBNOTE(2)
- +135 QUIT
- End DoDot:1
- +136 ;end - JWS;IB*2.0*592 US1108 - Dental
- +137 ;/ Beginning of IB*2.0*488 - Moved the following lines of code to IBCSC8 (vd)
- +138 ;I $P(IB("U2"),U,14)'="" W !,?4,"Homebound : ",$$EXPAND^IBTRE(399,236,$P(IB("U2"),U,14))
- +139 ;I $P(IB("U2"),U,15)'="" W !,?4,"Date Last Seen : ",$$EXPAND^IBTRE(399,237,$P(IB("U2"),U,15))
- +140 ;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:"")
- +141 ;/ End of IB*2.0*488 (vd)
- +142 ;
- +143 ; Section 7
- +144 SET Z=7
- SET IBW=1
- XECUTE IBWW
- +145 WRITE " Billing Provider : "
- +146 KILL IBZ
- +147 DO GETBP^IBCEF79(IBIFN,"",+$$B^IBCEF79(IBIFN),"CMS-1500 SCREEN 8",.IBZ)
- +148 SET IBZ=$GET(IBZ("CMS-1500 SCREEN 8","NAME"))
- +149 ; billing provider name
- WRITE $SELECT(IBZ'="":IBZ,1:IBU)
- +150 WRITE !?3," Taxonomy Code : "
- +151 SET IBZ=$$GET1^DIQ(8932.1,+$PIECE(IB("U3"),U,11),"X12 CODE")
- WRITE $SELECT(IBZ'="":IBZ,1:IBU)
- +152 SET IBZ=$$GET1^DIQ(8932.1,+$PIECE(IB("U3"),U,11),"SPECIALTY CODE")
- WRITE $SELECT(IBZ'="":" ("_IBZ_")",1:"")
- +153 ;
- +154 ; Section 8
- +155 ;WCJ;IB*2.0*547
- +156 ;Adding ALT PRIMARY IDS and moving sections down to make room
- +157 SET Z=8
- SET IBW=1
- XECUTE IBWW
- +158 WRITE " Alt Prim Payer ID : "
- +159 KILL IBZ
- +160 SET IBZCNT=0
- +161 IF $PIECE(IB("M2"),U,2)]""
- SET IBZCNT=IBZCNT+1
- SET IBZ(IBZCNT)="P: "_$PIECE(IB("M2"),U,2)
- +162 IF $PIECE(IB("M2"),U,4)]""
- SET IBZCNT=IBZCNT+1
- SET IBZ(IBZCNT)="S: "_$PIECE(IB("M2"),U,4)
- +163 IF $PIECE(IB("M2"),U,6)]""
- SET IBZCNT=IBZCNT+1
- SET IBZ(IBZCNT)="T: "_$PIECE(IB("M2"),U,6)
- +164 IF 'IBZCNT
- WRITE ?23,IBUN
- +165 IF IBZCNT
- FOR IBZ1=1:1:IBZCNT
- WRITE ?23,IBZ(IBZ1)
- if (IBZ1'=IBZCNT)
- WRITE !
- +166 KILL IBZ
- +167 ;
- +168 ; Section 9
- +169 SET Z=9
- SET IBW=1
- XECUTE IBWW
- +170 SET IBREQ=+$$REQMRA^IBEFUNC(IBIFN)
- if IBREQ
- SET IBREQ=1
- +171 SET IBMRASEC=$$MRASEC^IBCEF4(IBIFN)
- +172 WRITE " ",$SELECT('IBREQ:"Force To Print? : ",1:"Force MRA Sec Prt? : ")
- +173 SET IBZ=$$EXTERNAL^DILFD(399,27+IBREQ,,+$PIECE(IB("TX"),U,8+IBREQ))
- +174 IF IBMRASEC
- IF '$PIECE(IB("TX"),U,8)
- IF $PIECE(IB("TX"),U,9)
- SET IBZ="FORCED TO PRINT BY MRA PRIMARY"
- SET $PIECE(IB("TX"),U,8)=0
- +175 WRITE $SELECT(IBZ'=""&($PIECE(IB("TX"),U,8+IBREQ)'=""):IBZ,'$$TXMT^IBCEF4(IBIFN):"[NOT APPLICABLE - NOT TRANSMITTABLE]",IBREQ:"NO FORCED PRINT",1:IBZ)
- +176 ;
- +177 ; Section 10
- +178 SET Z=10
- SET IBW=1
- XECUTE IBWW
- +179 WRITE " Provider ID Maint : (Edit Provider ID information)",!
- +180 GOTO ^IBCSCP
- Q QUIT
- +1 ;
- WRT1(IBCRED) ; Write credentials mismatch
- +1 WRITE !,*7," **Warning** Credentials differ from those found in NEW PERSON or IB NON VA",!,$JUSTIFY("",14),"BILLING PROVIDER file (",$SELECT(IBCRED="":"none",1:IBCRED),")"
- +2 WRITE !,$JUSTIFY("",14),"Changes will print local, but only credentials on file transmit"
- +3 QUIT
- +4 ;
- NSAME(DA) ; Returns 1 if div on bill is not the default billing facility
- +1 QUIT ($PIECE($GET(^IBE(350.9,1,0)),U,2)'=$PIECE($GET(^DG(40.8,+$PIECE(^DGCR(399,DA,0),U,22),0)),U,7))
- +2 ;
- WRAP(STRING,ROOM,SUBS,IBARY) ; wrap long lines without breaking up words
- +1 ;
- +2 ; STRING = data string to wrap
- +3 ; ROOM = number of characters to break at for line 1
- +4 ; SUBS = number of characters to break at for subsequent lines (may or may not be same as ROOM)
- +5 ; IBARY = (required) subscripted array to return wrapped data in:
- +6 ; array(1)=first line
- +7 ; array(2)= 2nd line and so on
- +8 ;
- +9 ; Returns total # of lines in description
- +10 ;
- +11 NEW START,END,I,C,STOP
- +12 ; if there is enough room for 1 line, no wrapping needed
- +13 IF $LENGTH(STRING)'>ROOM
- SET IBARY(1)=STRING
- QUIT 1
- +14 IF $FIND(STRING," ")=0
- Begin DoDot:1
- +15 NEW LEN
- SET LEN=$LENGTH(STRING)
- +16 FOR I=1:1
- SET IBARY(I)=$EXTRACT(STRING,1,ROOM)
- SET STRING=$EXTRACT(STRING,ROOM+1,LEN)
- if STRING=""
- QUIT
- +17 QUIT
- End DoDot:1
- QUIT 1
- +18 IF $FIND(STRING," ")>ROOM
- SET IBARY(1)=STRING
- QUIT 1
- +19 ; add a space to the end of the string to avoid dropping last character
- +20 SET START=1
- SET END=ROOM
- SET STRING=STRING_" "
- +21 ; stop if we have made it to the end of the data string
- FOR C=1:1
- Begin DoDot:1
- +22 ; start at the end and work backwards until you find a blank space, cut the line there and move on to the next line
- +23 FOR I=END:-1:1
- IF $EXTRACT(STRING,I)=" "
- SET IBARY(C)=$EXTRACT(STRING,START,I)
- SET START=I+1
- SET END=SUBS+START
- QUIT
- +24 IF I=1
- SET STOP=1
- IF '$DATA(IBARY(1))
- SET IBARY(1)=STRING
- QUIT
- End DoDot:1
- if $LENGTH(STRING)<START
- QUIT
- if $GET(STOP)
- QUIT
- +25 QUIT C
- +26 ;
- +27 ;JWS;IB*2.0*592;only allow either Rendering or Assistant Surgeon on a Dental Claim
- FILTERP(IBIEN,TYPE) ;filter input of provider for dental claims
- +1 NEW OK,IBX1,IBX2
- +2 SET OK=1
- SET IBX1=0
- +3 FOR
- SET IBX1=$ORDER(^DGCR(399,IBIEN,"CP",IBX1))
- if 'IBX1
- QUIT
- Begin DoDot:1
- +4 IF TYPE=3
- IF $DATA(^DGCR(399,IBIEN,"CP",IBX1,"LNPRV","B",6))
- Begin DoDot:2
- +5 SET IBX2=$ORDER(^DGCR(399,IBIEN,"CP",IBX1,"LNPRV","B",6,0))
- IF IBX2=""
- QUIT
- +6 IF $PIECE($GET(^DGCR(399,IBIEN,"CP",IBX1,"LNPRV",IBX2,0)),"^",2)'=""
- SET OK=0
- QUIT
- End DoDot:2
- IF 'OK
- QUIT
- +7 IF TYPE=6
- IF $DATA(^DGCR(399,IBIEN,"CP",IBX1,"LNPRV","B",3))
- Begin DoDot:2
- +8 SET IBX2=$ORDER(^DGCR(399,IBIEN,"CP",IBX1,"LNPRV","B",3,0))
- IF IBX2=""
- QUIT
- +9 IF $PIECE($GET(^DGCR(399,IBIEN,"CP",IBX1,"LNPRV",IBX2,0)),"^",2)'=""
- SET OK=0
- QUIT
- End DoDot:2
- IF 'OK
- QUIT
- End DoDot:1
- if 'OK
- QUIT
- +10 IF OK
- IF TYPE=3
- IF $DATA(^DGCR(399,IBIEN,"PRV","B",6))
- Begin DoDot:1
- +11 SET IBX1=$ORDER(^DGCR(399,IBIEN,"PRV","B",6,0))
- IF IBX1=""
- QUIT
- +12 IF $PIECE($GET(^DGCR(399,IBIEN,"PRV",IBX1,0)),"^",2)'=""
- SET OK=0
- End DoDot:1
- +13 IF OK
- IF TYPE=6
- IF $DATA(^DGCR(399,IBIEN,"PRV","B",3))
- Begin DoDot:1
- +14 SET IBX1=$ORDER(^DGCR(399,IBIEN,"PRV","B",3,0))
- IF IBX1=""
- QUIT
- +15 IF $PIECE($GET(^DGCR(399,IBIEN,"PRV",IBX1,0)),"^",2)'=""
- SET OK=0
- End DoDot:1
- +16 QUIT OK
- +17 ;
- +18 ;IBCSC10H