IBCEP8B ;ALB/CJS - Functions for NON-VA PROVIDER cont'd ;06-06-08
;;2.0;INTEGRATED BILLING;**391,432,476,488,516**;21-MAR-94;Build 123
;;Per VA Directive 6402, this routine should not be modified.
;
BLD(IBNPRV) ; Build/Rebuild display
N IBLCT,IBCT,IBLST,IBPRI,IBIEN,Z,Z1,Z2,IB1
N IBFBTGL,IBFBOK ;IB*2.0*476
K @VALMAR
;S (IBLCT,IBCT)=0,Z=$G(^IBA(355.93,IBNPRV,0))
S (IBLCT,IBCT)=0,Z=$G(^IBA(355.93,IBNPRV,0)),IB1=$G(^IBA(355.93,IBNPRV,1))
;
; Moved IBCT & NAME into each section as the tabbing is different for each type IB*2*488
;S IBCT=IBCT+1
;S Z1=$J("Name: ",15)_$P(Z,U) D SET1(.IBLCT,Z1,IBCT)
;
I $P(Z,U,2)=2 D ; Individual provider (not a facility)
. S IBCT=IBCT+1
. S Z1=$J("Name: ",15)_$P(Z,U) D SET1(.IBLCT,Z1,IBCT)
. S IBCT=IBCT+1
. S Z1=$J("Type: ",15)_$S($P(Z,U,2)=2:"INDIVIDUAL PROVIDER",1:"OUTSIDE OR OTHER VA FACILITY") D SET1(.IBLCT,Z1,IBCT)
. S IBCT=IBCT+1
. S Z1=$J("Credentials: ",15)_$P(Z,U,3) D SET1(.IBLCT,Z1,IBCT)
. S IBCT=IBCT+1
. S Z1=$J("Specialty: ",15)_$P(Z,U,4) D SET1(.IBLCT,Z1,IBCT)
. S IBCT=IBCT+1
. S Z1=$J("NPI: ",15)_$$NPIGET^IBCEP81(IBNPRV) D SET1(.IBLCT,Z1,IBCT)
. S IBCT=IBCT+1
. S IBPRI=$$TAXGET^IBCEP81(IBNPRV,.IBLST)
. S Z1=$J("Taxonomy Code: ",15)_$P(IBPRI,U)
. I $D(IBLST) S Z1=Z1_" ("_$S($P(IBLST(IBLST),U,3)=1:"Primary",1:"Secondary")_")"
. D SET1(.IBLCT,Z1,IBCT)
. S IBIEN=""
. F S IBIEN=$O(IBLST(IBIEN)) Q:IBIEN="" D
.. I IBIEN=IBLST Q
.. S IBCT=IBCT+1
.. S Z1=$J("",15)_$P(IBLST(IBIEN),U)_" ("_$S($P(IBLST(IBIEN),U,3)=1:"Primary",1:"Secondary")_")"
.. D SET1(.IBLCT,Z1,IBCT)
. ;IB*2.0*476 - BEGIN added prompt to allow OPTION FB PAID TO IB to make updates or not
. S IBCT=IBCT+1
. S Z1=" " D SET1(.IBLCT,Z1,IBCT)
. S IBCT=IBCT+1
. S IBFBTGL=$$FBTGLGET^IBCEP8C1(IBNPRV) ;RETURNS 0,1 OR ""
. S IBFBOK="YES"
. S:IBFBTGL=0 IBFBOK="NO"
. S Z1=$J("Allow future updates by FEE BASIS automatic interface? : ",50)_IBFBOK
. D SET1(.IBLCT,Z1,IBCT)
;E D
I $P(Z,U,2)'=2 D
.;IB*2.0*476 - END added prompt to allow OPTION FB PAID TO IB to make updates or not
. S IBCT=IBCT+1
. S Z1=$J("Name: ",19)_$P(Z,U) D SET1(.IBLCT,Z1,IBCT)
. ;;
. ;; Begin IB*2.0*488 -RBN
. ;;
. N XX,BADADD,BADZIP,MSG
. S MSG=" "
. S (BADADD,BADZIP)=0
. S XX=$P(Z,U,5)
. I $L(XX)>30!($L(XX)<1) S BADADD=1
. S BADADD=$$BADADD(XX)
. S XX=$P(Z,U,8)
. I $L(XX)>10!($L(XX)<9)!'((XX?9N)!(XX?5N1"-"4N))!($E(XX,$L(XX)-3,$L(XX))="0000") S BADZIP=1
. ;;
. ;; End IB*2.0*488
. ;;
. S IBCT=IBCT+1
. S Z1=$J("Address: ",19)_$P(Z,U,5) D SET1(.IBLCT,Z1,IBCT)
. I $P(Z,U,10) D
.. S IBCT=IBCT+1
.. S Z1=$J("",19)_$P(Z,U,10) ; This is the street2 of the address - NOT displayed
. S IBCT=IBCT+1
. S Z1=$J("",19)_$P(Z,U,6)_$S($P(Z,U,6)'="":", ",1:"")_$S($P(Z,U,7):$$EXTERNAL^DILFD(355.93,.07,"",$P(Z,U,7))_" ",1:"")_$P(Z,U,8)
. D SET1(.IBLCT,Z1,IBCT)
. ;;
. ;; Begin IB*2.0*488 - RBN
. ;;
. I BADADD S MSG=MSG_"Address cannot be a PO BOX"
. I BADZIP S MSG=$S(MSG'=" ":MSG_" & ",1:MSG) S MSG=MSG_"ZIP must be 9-10 digits not ending in 0000"
. I BADADD!BADZIP D
. . S IBCT=IBCT+1
. . S Z1=" "
. . D SET1(.IBLCT,Z1,IBCT)
. . S IBCT=IBCT+1
. . D SET1(.IBLCT,MSG,IBCT)
. . S IBCT=IBCT+1
. . S Z1=" "
. . D SET1(.IBLCT,Z1,IBCT)
. ;;
. ;; End IB*2.0*488
. ;;
. ; start contact changes here
. S IBCT=IBCT+1
. S Z1=$J("P&C Contact Name: ",19)_$P(IB1,U,1) D SET1(.IBLCT,Z1,IBCT)
. S IBCT=IBCT+1
. S Z1=$J("P&C Contact Phone: ",19)_$P(IB1,U,2)_" "_$P(IB1,U,3) D SET1(.IBLCT,Z1,IBCT)
. S IBCT=IBCT+1
. S Z1=" " D SET1(.IBLCT,Z1,IBCT)
. S IBCT=IBCT+1
. S Z1=$J("Type of Facility: ",30)_$$EXTERNAL^DILFD(355.93,.11,,$P(Z,U,11))
. D SET1(.IBLCT,Z1,IBCT)
. S IBCT=IBCT+1
. S Z1=$J("Primary ID: ",30)_$P(Z,U,9)
. D SET1(.IBLCT,Z1,IBCT)
. S IBCT=IBCT+1
. S Z1=$J("ID Qualifier: ",30)_$$GET1^DIQ(355.97,$P(Z,U,13),.03) I $P(Z,U,13)]"" S Z1=Z1_" - "_$$GET1^DIQ(355.97,$P(Z,U,13),.01)
. D SET1(.IBLCT,Z1,IBCT)
. S IBCT=IBCT+1
. S Z1=$J("Mammography Certification #: ",30)_$P(Z,U,15)
. D SET1(.IBLCT,Z1,IBCT)
. S IBCT=IBCT+1
. S Z1=$J("Sole Proprietor: ",30)_$S($P(Z,U,18):$$GET1^DIQ(355.93,$P(Z,U,18),.01),1:"NO")
. D SET1(.IBLCT,Z1,IBCT)
. S IBCT=IBCT+1
. S Z1=$J("NPI: ",30)_$$NPIGET^IBCEP81(IBNPRV) D SET1(.IBLCT,Z1,IBCT)
. S IBCT=IBCT+1
. S IBPRI=$$TAXGET^IBCEP81(IBNPRV,.IBLST)
. S Z1=$J("Taxonomy Code: ",30)_$P(IBPRI,U)
. I $D(IBLST) S Z1=Z1_" ("_$S($P(IBLST(IBLST),U,3)=1:"Primary",1:"Secondary")_")"
. D SET1(.IBLCT,Z1,IBCT)
. S IBIEN=""
. F S IBIEN=$O(IBLST(IBIEN)) Q:IBIEN="" D
.. I IBIEN=IBLST Q
.. S IBCT=IBCT+1
.. S Z1=$J("",30)_$P(IBLST(IBIEN),U)_" ("_$S($P(IBLST(IBIEN),U,3)=1:"Primary",1:"Secondary")_")"
.. D SET1(.IBLCT,Z1,IBCT)
. ;IB*2.0*476 - BEGIN added prompt to allow OPTION FB PAID TO IB to make updates or not
. S IBCT=IBCT+1
. S Z1=" " D SET1(.IBLCT,Z1,IBCT)
. S IBCT=IBCT+1
. S IBFBTGL=$$FBTGLGET^IBCEP8C1(IBNPRV) ;RETURNS 1,0 OR ""
. S IBFBOK="YES"
. S:IBFBTGL=0 IBFBOK="NO"
. S Z1=$J("Allow future updates by FEE BASIS automatic interface? : ",60)_IBFBOK
. D SET1(.IBLCT,Z1,IBCT)
. ;IB*2.0*476 - END added prompt to allow OPTION FB PAID TO IB to make updates or not
K VALMBG,VALMCNT
S VALMBG=1,VALMCNT=IBLCT
Q
;
SET1(IBLCT,TEXT,IBCT) ;
S IBLCT=IBLCT+1 D SET^VALM10(IBLCT,TEXT,$G(IBCT))
Q
;
; This checks for a post office box. baa *488*
; Called by the input transform for file 355.93 field .05 Street Address.
;
BADADD(XX) ;
N NOK,BADADD
S NOK=0
S XX=$$UP^XLFSTR(XX) ;make lower case upper
I XX[" BOX #" S NOK=1
I XX?.E1"BOX"." "."#"." "1N.E S NOK=1
S XX=$$STRIP^XLFSTR(XX,". ") ; strip out punctuation
I XX="BOX" S NOK=1
I XX="BOX#" S NOK=1
I XX="PO" S NOK=1
I XX="POB" S NOK=1
I XX="POBOX" S NOK=1
I XX="POSTALBOX" S NOK=1
Q NOK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEP8B 5879 printed Dec 13, 2024@02:11:51 Page 2
IBCEP8B ;ALB/CJS - Functions for NON-VA PROVIDER cont'd ;06-06-08
+1 ;;2.0;INTEGRATED BILLING;**391,432,476,488,516**;21-MAR-94;Build 123
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
BLD(IBNPRV) ; Build/Rebuild display
+1 NEW IBLCT,IBCT,IBLST,IBPRI,IBIEN,Z,Z1,Z2,IB1
+2 ;IB*2.0*476
NEW IBFBTGL,IBFBOK
+3 KILL @VALMAR
+4 ;S (IBLCT,IBCT)=0,Z=$G(^IBA(355.93,IBNPRV,0))
+5 SET (IBLCT,IBCT)=0
SET Z=$GET(^IBA(355.93,IBNPRV,0))
SET IB1=$GET(^IBA(355.93,IBNPRV,1))
+6 ;
+7 ; Moved IBCT & NAME into each section as the tabbing is different for each type IB*2*488
+8 ;S IBCT=IBCT+1
+9 ;S Z1=$J("Name: ",15)_$P(Z,U) D SET1(.IBLCT,Z1,IBCT)
+10 ;
+11 ; Individual provider (not a facility)
IF $PIECE(Z,U,2)=2
Begin DoDot:1
+12 SET IBCT=IBCT+1
+13 SET Z1=$JUSTIFY("Name: ",15)_$PIECE(Z,U)
DO SET1(.IBLCT,Z1,IBCT)
+14 SET IBCT=IBCT+1
+15 SET Z1=$JUSTIFY("Type: ",15)_$SELECT($PIECE(Z,U,2)=2:"INDIVIDUAL PROVIDER",1:"OUTSIDE OR OTHER VA FACILITY")
DO SET1(.IBLCT,Z1,IBCT)
+16 SET IBCT=IBCT+1
+17 SET Z1=$JUSTIFY("Credentials: ",15)_$PIECE(Z,U,3)
DO SET1(.IBLCT,Z1,IBCT)
+18 SET IBCT=IBCT+1
+19 SET Z1=$JUSTIFY("Specialty: ",15)_$PIECE(Z,U,4)
DO SET1(.IBLCT,Z1,IBCT)
+20 SET IBCT=IBCT+1
+21 SET Z1=$JUSTIFY("NPI: ",15)_$$NPIGET^IBCEP81(IBNPRV)
DO SET1(.IBLCT,Z1,IBCT)
+22 SET IBCT=IBCT+1
+23 SET IBPRI=$$TAXGET^IBCEP81(IBNPRV,.IBLST)
+24 SET Z1=$JUSTIFY("Taxonomy Code: ",15)_$PIECE(IBPRI,U)
+25 IF $DATA(IBLST)
SET Z1=Z1_" ("_$SELECT($PIECE(IBLST(IBLST),U,3)=1:"Primary",1:"Secondary")_")"
+26 DO SET1(.IBLCT,Z1,IBCT)
+27 SET IBIEN=""
+28 FOR
SET IBIEN=$ORDER(IBLST(IBIEN))
if IBIEN=""
QUIT
Begin DoDot:2
+29 IF IBIEN=IBLST
QUIT
+30 SET IBCT=IBCT+1
+31 SET Z1=$JUSTIFY("",15)_$PIECE(IBLST(IBIEN),U)_" ("_$SELECT($PIECE(IBLST(IBIEN),U,3)=1:"Primary",1:"Secondary")_")"
+32 DO SET1(.IBLCT,Z1,IBCT)
End DoDot:2
+33 ;IB*2.0*476 - BEGIN added prompt to allow OPTION FB PAID TO IB to make updates or not
+34 SET IBCT=IBCT+1
+35 SET Z1=" "
DO SET1(.IBLCT,Z1,IBCT)
+36 SET IBCT=IBCT+1
+37 ;RETURNS 0,1 OR ""
SET IBFBTGL=$$FBTGLGET^IBCEP8C1(IBNPRV)
+38 SET IBFBOK="YES"
+39 if IBFBTGL=0
SET IBFBOK="NO"
+40 SET Z1=$JUSTIFY("Allow future updates by FEE BASIS automatic interface? : ",50)_IBFBOK
+41 DO SET1(.IBLCT,Z1,IBCT)
End DoDot:1
+42 ;E D
+43 IF $PIECE(Z,U,2)'=2
Begin DoDot:1
+44 ;IB*2.0*476 - END added prompt to allow OPTION FB PAID TO IB to make updates or not
+45 SET IBCT=IBCT+1
+46 SET Z1=$JUSTIFY("Name: ",19)_$PIECE(Z,U)
DO SET1(.IBLCT,Z1,IBCT)
+47 ;;
+48 ;; Begin IB*2.0*488 -RBN
+49 ;;
+50 NEW XX,BADADD,BADZIP,MSG
+51 SET MSG=" "
+52 SET (BADADD,BADZIP)=0
+53 SET XX=$PIECE(Z,U,5)
+54 IF $LENGTH(XX)>30!($LENGTH(XX)<1)
SET BADADD=1
+55 SET BADADD=$$BADADD(XX)
+56 SET XX=$PIECE(Z,U,8)
+57 IF $LENGTH(XX)>10!($LENGTH(XX)<9)!'((XX?9N)!(XX?5N1"-"4N))!($EXTRACT(XX,$LENGTH(XX)-3,$LENGTH(XX))="0000")
SET BADZIP=1
+58 ;;
+59 ;; End IB*2.0*488
+60 ;;
+61 SET IBCT=IBCT+1
+62 SET Z1=$JUSTIFY("Address: ",19)_$PIECE(Z,U,5)
DO SET1(.IBLCT,Z1,IBCT)
+63 IF $PIECE(Z,U,10)
Begin DoDot:2
+64 SET IBCT=IBCT+1
+65 ; This is the street2 of the address - NOT displayed
SET Z1=$JUSTIFY("",19)_$PIECE(Z,U,10)
End DoDot:2
+66 SET IBCT=IBCT+1
+67 SET Z1=$JUSTIFY("",19)_$PIECE(Z,U,6)_$SELECT($PIECE(Z,U,6)'="":", ",1:"")_$SELECT($PIECE(Z,U,7):$$EXTERNAL^DILFD(355.93,.07,"",$PIECE(Z,U,7))_" ",1:"")_$PIECE(Z,U,8)
+68 DO SET1(.IBLCT,Z1,IBCT)
+69 ;;
+70 ;; Begin IB*2.0*488 - RBN
+71 ;;
+72 IF BADADD
SET MSG=MSG_"Address cannot be a PO BOX"
+73 IF BADZIP
SET MSG=$SELECT(MSG'=" ":MSG_" & ",1:MSG)
SET MSG=MSG_"ZIP must be 9-10 digits not ending in 0000"
+74 IF BADADD!BADZIP
Begin DoDot:2
+75 SET IBCT=IBCT+1
+76 SET Z1=" "
+77 DO SET1(.IBLCT,Z1,IBCT)
+78 SET IBCT=IBCT+1
+79 DO SET1(.IBLCT,MSG,IBCT)
+80 SET IBCT=IBCT+1
+81 SET Z1=" "
+82 DO SET1(.IBLCT,Z1,IBCT)
End DoDot:2
+83 ;;
+84 ;; End IB*2.0*488
+85 ;;
+86 ; start contact changes here
+87 SET IBCT=IBCT+1
+88 SET Z1=$JUSTIFY("P&C Contact Name: ",19)_$PIECE(IB1,U,1)
DO SET1(.IBLCT,Z1,IBCT)
+89 SET IBCT=IBCT+1
+90 SET Z1=$JUSTIFY("P&C Contact Phone: ",19)_$PIECE(IB1,U,2)_" "_$PIECE(IB1,U,3)
DO SET1(.IBLCT,Z1,IBCT)
+91 SET IBCT=IBCT+1
+92 SET Z1=" "
DO SET1(.IBLCT,Z1,IBCT)
+93 SET IBCT=IBCT+1
+94 SET Z1=$JUSTIFY("Type of Facility: ",30)_$$EXTERNAL^DILFD(355.93,.11,,$PIECE(Z,U,11))
+95 DO SET1(.IBLCT,Z1,IBCT)
+96 SET IBCT=IBCT+1
+97 SET Z1=$JUSTIFY("Primary ID: ",30)_$PIECE(Z,U,9)
+98 DO SET1(.IBLCT,Z1,IBCT)
+99 SET IBCT=IBCT+1
+100 SET Z1=$JUSTIFY("ID Qualifier: ",30)_$$GET1^DIQ(355.97,$PIECE(Z,U,13),.03)
IF $PIECE(Z,U,13)]""
SET Z1=Z1_" - "_$$GET1^DIQ(355.97,$PIECE(Z,U,13),.01)
+101 DO SET1(.IBLCT,Z1,IBCT)
+102 SET IBCT=IBCT+1
+103 SET Z1=$JUSTIFY("Mammography Certification #: ",30)_$PIECE(Z,U,15)
+104 DO SET1(.IBLCT,Z1,IBCT)
+105 SET IBCT=IBCT+1
+106 SET Z1=$JUSTIFY("Sole Proprietor: ",30)_$SELECT($PIECE(Z,U,18):$$GET1^DIQ(355.93,$PIECE(Z,U,18),.01),1:"NO")
+107 DO SET1(.IBLCT,Z1,IBCT)
+108 SET IBCT=IBCT+1
+109 SET Z1=$JUSTIFY("NPI: ",30)_$$NPIGET^IBCEP81(IBNPRV)
DO SET1(.IBLCT,Z1,IBCT)
+110 SET IBCT=IBCT+1
+111 SET IBPRI=$$TAXGET^IBCEP81(IBNPRV,.IBLST)
+112 SET Z1=$JUSTIFY("Taxonomy Code: ",30)_$PIECE(IBPRI,U)
+113 IF $DATA(IBLST)
SET Z1=Z1_" ("_$SELECT($PIECE(IBLST(IBLST),U,3)=1:"Primary",1:"Secondary")_")"
+114 DO SET1(.IBLCT,Z1,IBCT)
+115 SET IBIEN=""
+116 FOR
SET IBIEN=$ORDER(IBLST(IBIEN))
if IBIEN=""
QUIT
Begin DoDot:2
+117 IF IBIEN=IBLST
QUIT
+118 SET IBCT=IBCT+1
+119 SET Z1=$JUSTIFY("",30)_$PIECE(IBLST(IBIEN),U)_" ("_$SELECT($PIECE(IBLST(IBIEN),U,3)=1:"Primary",1:"Secondary")_")"
+120 DO SET1(.IBLCT,Z1,IBCT)
End DoDot:2
+121 ;IB*2.0*476 - BEGIN added prompt to allow OPTION FB PAID TO IB to make updates or not
+122 SET IBCT=IBCT+1
+123 SET Z1=" "
DO SET1(.IBLCT,Z1,IBCT)
+124 SET IBCT=IBCT+1
+125 ;RETURNS 1,0 OR ""
SET IBFBTGL=$$FBTGLGET^IBCEP8C1(IBNPRV)
+126 SET IBFBOK="YES"
+127 if IBFBTGL=0
SET IBFBOK="NO"
+128 SET Z1=$JUSTIFY("Allow future updates by FEE BASIS automatic interface? : ",60)_IBFBOK
+129 DO SET1(.IBLCT,Z1,IBCT)
+130 ;IB*2.0*476 - END added prompt to allow OPTION FB PAID TO IB to make updates or not
End DoDot:1
+131 KILL VALMBG,VALMCNT
+132 SET VALMBG=1
SET VALMCNT=IBLCT
+133 QUIT
+134 ;
SET1(IBLCT,TEXT,IBCT) ;
+1 SET IBLCT=IBLCT+1
DO SET^VALM10(IBLCT,TEXT,$GET(IBCT))
+2 QUIT
+3 ;
+4 ; This checks for a post office box. baa *488*
+5 ; Called by the input transform for file 355.93 field .05 Street Address.
+6 ;
BADADD(XX) ;
+1 NEW NOK,BADADD
+2 SET NOK=0
+3 ;make lower case upper
SET XX=$$UP^XLFSTR(XX)
+4 IF XX[" BOX #"
SET NOK=1
+5 IF XX?.E1"BOX"." "."#"." "1N.E
SET NOK=1
+6 ; strip out punctuation
SET XX=$$STRIP^XLFSTR(XX,". ")
+7 IF XX="BOX"
SET NOK=1
+8 IF XX="BOX#"
SET NOK=1
+9 IF XX="PO"
SET NOK=1
+10 IF XX="POB"
SET NOK=1
+11 IF XX="POBOX"
SET NOK=1
+12 IF XX="POSTALBOX"
SET NOK=1
+13 QUIT NOK
