- 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 Jan 18, 2025@03:13:04 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