IBCEF77 ;WOIFO/SS - FORMATTER/EXTRACT BILL FUNCTIONS ;31-JUL-03
;;2.0;INTEGRATED BILLING;**232,280,155,290,291,320,348,349,516,577,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
SORT(IBPRNUM,IBPRTYP,IB399,IBSRC,IBDST,IBN,IBEXC,IBSEQ,IBLIMIT) ;
N IBXIEN,IBXDATA,IBNET,IBTRI,IB1,IB2,IBID,Z,IBZ,IBZ1,IBSVP
S (IB1,IB2,IBZ,IBZ1,IBTRI)=""
D F^IBCEF("N-ALL ATT/RENDERING PROV SSN","IBZ",,IB399)
S IBZ1=$$ALLPTYP^IBCEF3(IB399)
F Z=1:1:3 S $P(IBZ1,U,Z)=$S($P(IBZ1,U,Z)="CH":1,1:"") S:$P(IBZ1,U,Z) IBTRI=1
S IBNET=$$NETID^IBCEP() ; netwrk id type
I $G(IBN) D
. S Z=0 F S Z=$O(IBDST(IBPRNUM,IBPRTYP,Z)) Q:'Z S IBID(+$P(IBDST(IBPRNUM,IBPRTYP,Z),U,9))=""
F S IB1=$O(IBSRC(IB1)) Q:IB1="" D Q:IBN=IBLIMIT
. N OK,IBSTLIC
. S IBSTLIC=""
. F S IB2=$O(IBSRC(IB1,IB2)) Q:IB2="" D Q:IBN=IBLIMIT
. . S IBSVP=$P(IBSRC(IB1,IB2),U)
. . ; If ID overridden, output no others of this type
. . I $G(IBEXC),$P($G(IBSRC(IB1,IB2)),U,9)=IBEXC Q
. . ; Ck state of care/lic match if st lic#
. . I $P($G(IBSRC(IB1,IB2)),U,3)="0B" S OK=1 D Q:'OK
. . . I +$$CAREST^IBCEP2A(IB399)'=$P(IBSRC(IB1,IB2),U,7) S IBSTLIC=1 Q
. . . I $G(IBSTLIC(0))'="" S OK=0 Q
. . . S IBSTLIC(0)=$G(IBSRC(IB1,IB2)),OK=0
. . ; Exclude SSN from sec ids unless required
. . I $P($G(IBSRC(IB1,IB2)),U,3)="SY" Q
. . ; Only 1 of each prov id type
. . Q:$D(IBID(+$P($G(IBSRC(IB1,IB2)),U,9)))
. . S IBN=IBN+1,IBID(+$P($G(IBSRC(IB1,IB2)),U,9))=""
. . S IBDST(IBPRNUM,IBPRTYP,IBN)=$G(IBSRC(IB1,IB2))
. I IBN'=IBLIMIT,'$G(IBSTLIC),$G(IBSTLIC(0))'="" S IBN=IBN+1,IBDST(IBPRNUM,IBPRTYP,IBN)=IBSTLIC(0)
;JRA IB*2.0*592 Treat Dental Form 7 (J430D) same as CMS-1500 - added 'FT'
;I $$FT^IBCEF(IB399)=2,$G(IBID(IBNET))="",IBTRI,$P(IBZ1,U,IBSEQ) D ; WCJ 02/13/2006 ;JRA IB*2.0*592 ';'
N FT S FT=$$FT^IBCEF(IB399) ;JRA IB*2.0*592
I (FT=2!(FT=7)),$G(IBID(IBNET))="",IBTRI,$P(IBZ1,U,IBSEQ) D ;JRA IB*2.0*592
. Q:$P(IBZ,U,IBPRTYP)=""
. ; here, no network id & TRICARE ins co.
. N Z
. S Z=+$O(^DGCR(399,IB399,"PRV","B",IBPRTYP,0)),Z=$P($G(^DGCR(399,IB399,"PRV",Z,0)),U,2)
. S IBN=IBN+1,IBDST(IBPRNUM,IBPRTYP,IBN)=Z_U_+$$POLICY^IBCEF(IB399,1,IBSEQ)_U_$P($G(^IBE(355.97,IBNET,0)),U,3)_U_$P(IBZ,U,IBPRTYP)_U_"0^0^^^"_IBNET
Q
;
; esg - 8/25/06 - IB*2*348 - CFIDS function
;
CFIDS(IBIFN,PRVTYP,ALLOWIDS) ; Claim Form IDs for human providers
; Function returns a 3 piece string: [1] default secondary ID qual
; [2] default secondary ID
; [3] NPI
; Input: IBIFN - internal claim#
; PRVTYP - internal provider type ID number
; - 1:REFER;2:OPER;3:REND;4:ATT;5:SUPER;9:OTHER
; - if blank, then default Att/Rend based on form type
; ALLOWIDS - List of allowable Secondary IDS ^ delimited.
; ex "^1A^1B^1C^1H^G2^LU^N5^"
; UB-04 only wants IDs provided by the payer, not the providers own IDS
; Also, they want the qualifier to be G2 (Commercial)
; if it is a payer provided ID
NEW ID,FT,IBZ,IBQ,IBSID,IBNPI,I,OK
S ID=""
I '$G(IBIFN) G CFIDSX
S FT=$$FT^IBCEF(IBIFN)
I '$G(PRVTYP) S PRVTYP=3 I FT=3 S PRVTYP=4
D ALLIDS^IBCEF75(IBIFN,.IBZ,1)
S OK=0 I $G(ALLOWIDS)="" S OK=1
F I=1:1 D Q:OK
. S IBQ=$P($G(IBZ("PROVINF",IBIFN,"C",1,PRVTYP,I)),U,3) ; qualifier
. S IBSID=$P($G(IBZ("PROVINF",IBIFN,"C",1,PRVTYP,I)),U,4) ; ID#
. I IBQ="",IBSID="" S OK=1 Q
. Q:OK
. I $G(ALLOWIDS)[(U_IBQ_U) S OK=1,IBQ="G2" Q
. S (IBQ,IBSID)=""
S IBNPI=""
D F^IBCEF("N-PROVIDER NPI CODES","IBNPI",,IBIFN)
S IBNPI=$P(IBNPI,U,PRVTYP) ; NPI
;
; special check for the referring doc
I PRVTYP=1,$D(IBZ("PROVINF",IBIFN,"C",1,PRVTYP)),IBQ="",IBSID="" S IBQ="1G",IBSID="VAD000"
;
; If UB-04 and no IDs, use VA UPIN as deafult
I $D(IBZ("PROVINF",IBIFN,"C",1,PRVTYP)),FT=3,IBQ="",IBSID="" S IBQ="1G",IBSID="VAD000"
;
; determine if legacy ID's should be displayed
I '$$PRTLID(IBIFN,IBNPI) S (IBQ,IBSID)=""
;
S ID=IBQ_U_IBSID_U_IBNPI
CFIDSX ;
Q ID
;
DOL(AMT,LEN,DEC) ; format dollar amounts for printed claim forms
; AMT = amount to be formatted
; LEN = length of field - right justified to this length
; DEC = flag to include the decimal point or not
; DEFAULT value is to not include the decimal point
; if DEC is not defined or 0, assume no decimal point
; so 15 will be returned as 1500, 6.77 will be returned as 677
; if DEC is 1, then the decimal point will be included
;
S LEN=$G(LEN,10),DEC=$G(DEC,0) ; defaults
S AMT=$FN(+$G(AMT),"",2) ; format # with 2 decimals
I 'DEC S AMT=$TR(AMT,".") ; strip or leave decimal
S AMT=$J(AMT,LEN) ; right justify
Q AMT
;
PRTLID(IBIFN,NPI) ; YMG; Print Legacy IDs on the CMS-1500 or UB-04 form
; Function fetches form type associated with given claim number
; (values: 2 - CMS-1500 form, 3 - UB-04 form), then looks at
; "Print Legacy ID" site parameter for this particular form type.
;
; Possible site parameter values are:
; "Y" - always print Legacy ID
; "N" - never print Legacy ID
; "C" - only print Legacy ID if NPI is not available.
;
; This information is used to determine if Legacy ID should be printed
; for claim number in question.
;
; Note: Situation when "Print Legacy ID" site parameter is not set is treated
; as if this parameter was set to "Y" - always print Legacy ID.
;
; Input:
; IBIFN - internal claim number
; NPI - NPI number (or "" if no NPI is available)
;
; Returns:
; 0 - Legacy ID should not be printed
; 1 - Legacy ID should be printed
;
;JRA IB*2.0*592 Treat Dental Form 7 (J430D) same as CMS-1500 - added 'FT'
;Q $S(NPI="":"YC",1:"Y")[$P($G(^IBE(350.9,1,1)),U,$S($$FT^IBCEF(IBIFN)=2:32,1:33)) ;JRA IB*2.0*592 ';'
N FT S FT=$$FT^IBCEF(IBIFN) ;JRA IB*2.0*592
;JWS;IB*2.0*592 - NO legacy id's for dental
I FT=7 Q 0
Q $S(NPI="":"YC",1:"Y")[$P($G(^IBE(350.9,1,1)),U,$S(FT=2:32,1:33)) ;JRA IB*2.0*592
;
; for claim IBIFN. Data pulled from field# 402 of file 399 and
; formatted into an array IBXDATA(n) where each line is not greater
; than 24 characters long. This will fit into UB-04 FL-80.
;
; OFLG=1 only when called in the output formatter. In this case, only
; 4 lines in IBXDATA will be returned.
;
NEW TEXT,LEN,IBZ,J,PCE,CHS,NEWCHS,IBK,J,TX,IBCP1
K IBXDATA
;
; MRD;IB*2.0*516 - Pull the Bill Remarks for the claim. If this was
; called from the Output Formatter, then look at lines of claim for
; NDC's. If any are found, they should be added to the end of TEXT.
;
S TEXT=$P($G(^DGCR(399,+$G(IBIFN),"UF2")),U,3)
; VAD/ Begin of IB*2*577 changes
; NDC, Quantity, and Unit of Measure now printed in FL-43
; instead of here in FL-80
;I $G(OFLG) D
;. S J=0
;. F S J=$O(^DGCR(399,+$G(IBIFN),"CP",J)) Q:'J S IBCP1=$G(^(J,1)) I $P(IBCP1,U,7)'="" D
;. . I TEXT'="" S TEXT=TEXT_" "
;. . S TEXT=TEXT_"N4"_$TR($P(IBCP1,U,7),"-")_" UN"_$P(IBCP1,U,8)
;. . Q
;. Q
; VAD/ End of IB*2*577 changes
;
; If there's nothing in TEXT, then Quit.
;
I TEXT="" Q
;
; need to break up large words for word wrapping purposes to get
; as many characters as possible in the box.
S LEN=17
F PCE=1:1 Q:PCE>$L(TEXT," ") S CHS=$P(TEXT," ",PCE) I $L(CHS)>LEN D
. S NEWCHS=$E(CHS,1,LEN)_" "_$E(CHS,LEN+1,999)
. S $P(TEXT," ",PCE)=NEWCHS
. Q
;
; When calling FSTRNG^IBJU1 which calls ^DIWP, FileMan builds the
; array with strings of max length=1 less than what you tell it.
;
S LEN=20 ; line 1 is 19 chars
D FSTRNG^IBJU1(TEXT,LEN,.IBZ) ; build IBZ array
S IBK=$$TRIM^XLFSTR($G(IBZ(1))) ; save off the first line
S TEXT=$P(TEXT,IBK,2,99) ; restore the rest of the text
S TEXT=$$TRIM^XLFSTR(TEXT) ; trim spaces
;
S LEN=25 ; the rest is 24 chars
D FSTRNG^IBJU1(TEXT,LEN,.IBZ) ; build IBZ array
S IBXDATA(1)=" "_IBK ; line 1
S J=0 F S J=$O(IBZ(J)) Q:'J D ; lines 2-n
. I J>3,$G(OFLG) Q ; only 4 lines for output formatter
. S TX=$$TRIM^XLFSTR($G(IBZ(J)))
. I TX'="" S IBXDATA(J+1)=TX
. Q
Q
;
B43(NDCDATA) ; This is passed a string and properly formats if there is NDC drug information.
; The drug information is in pieces 21-23 of that string.
; It was part of the output formatter entry 364.7[1406] used for FL43 but that got too big for a FileMan Mumps data element
; It returns a string with N4 - the NDC Drug qualifier
; NDC Code without the hyphens
; a space
; Units qualifier
; Units
; Ex "N412345678901 ML1.5"
I NDCDATA="" Q ""
S NDCDATA=$P(NDCDATA,U,21,23)
Q:$P(NDCDATA,U)="" ""
Q "N4"_$TR($P(NDCDATA,U),"-")_" "_$TR($P(NDCDATA,U,2,3),U)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF77 9176 printed Dec 13, 2024@02:10:19 Page 2
IBCEF77 ;WOIFO/SS - FORMATTER/EXTRACT BILL FUNCTIONS ;31-JUL-03
+1 ;;2.0;INTEGRATED BILLING;**232,280,155,290,291,320,348,349,516,577,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
SORT(IBPRNUM,IBPRTYP,IB399,IBSRC,IBDST,IBN,IBEXC,IBSEQ,IBLIMIT) ;
+1 NEW IBXIEN,IBXDATA,IBNET,IBTRI,IB1,IB2,IBID,Z,IBZ,IBZ1,IBSVP
+2 SET (IB1,IB2,IBZ,IBZ1,IBTRI)=""
+3 DO F^IBCEF("N-ALL ATT/RENDERING PROV SSN","IBZ",,IB399)
+4 SET IBZ1=$$ALLPTYP^IBCEF3(IB399)
+5 FOR Z=1:1:3
SET $PIECE(IBZ1,U,Z)=$SELECT($PIECE(IBZ1,U,Z)="CH":1,1:"")
if $PIECE(IBZ1,U,Z)
SET IBTRI=1
+6 ; netwrk id type
SET IBNET=$$NETID^IBCEP()
+7 IF $GET(IBN)
Begin DoDot:1
+8 SET Z=0
FOR
SET Z=$ORDER(IBDST(IBPRNUM,IBPRTYP,Z))
if 'Z
QUIT
SET IBID(+$PIECE(IBDST(IBPRNUM,IBPRTYP,Z),U,9))=""
End DoDot:1
+9 FOR
SET IB1=$ORDER(IBSRC(IB1))
if IB1=""
QUIT
Begin DoDot:1
+10 NEW OK,IBSTLIC
+11 SET IBSTLIC=""
+12 FOR
SET IB2=$ORDER(IBSRC(IB1,IB2))
if IB2=""
QUIT
Begin DoDot:2
+13 SET IBSVP=$PIECE(IBSRC(IB1,IB2),U)
+14 ; If ID overridden, output no others of this type
+15 IF $GET(IBEXC)
IF $PIECE($GET(IBSRC(IB1,IB2)),U,9)=IBEXC
QUIT
+16 ; Ck state of care/lic match if st lic#
+17 IF $PIECE($GET(IBSRC(IB1,IB2)),U,3)="0B"
SET OK=1
Begin DoDot:3
+18 IF +$$CAREST^IBCEP2A(IB399)'=$PIECE(IBSRC(IB1,IB2),U,7)
SET IBSTLIC=1
QUIT
+19 IF $GET(IBSTLIC(0))'=""
SET OK=0
QUIT
+20 SET IBSTLIC(0)=$GET(IBSRC(IB1,IB2))
SET OK=0
End DoDot:3
if 'OK
QUIT
+21 ; Exclude SSN from sec ids unless required
+22 IF $PIECE($GET(IBSRC(IB1,IB2)),U,3)="SY"
QUIT
+23 ; Only 1 of each prov id type
+24 if $DATA(IBID(+$PIECE($GET(IBSRC(IB1,IB2)),U,9)))
QUIT
+25 SET IBN=IBN+1
SET IBID(+$PIECE($GET(IBSRC(IB1,IB2)),U,9))=""
+26 SET IBDST(IBPRNUM,IBPRTYP,IBN)=$GET(IBSRC(IB1,IB2))
End DoDot:2
if IBN=IBLIMIT
QUIT
+27 IF IBN'=IBLIMIT
IF '$GET(IBSTLIC)
IF $GET(IBSTLIC(0))'=""
SET IBN=IBN+1
SET IBDST(IBPRNUM,IBPRTYP,IBN)=IBSTLIC(0)
End DoDot:1
if IBN=IBLIMIT
QUIT
+28 ;JRA IB*2.0*592 Treat Dental Form 7 (J430D) same as CMS-1500 - added 'FT'
+29 ;I $$FT^IBCEF(IB399)=2,$G(IBID(IBNET))="",IBTRI,$P(IBZ1,U,IBSEQ) D ; WCJ 02/13/2006 ;JRA IB*2.0*592 ';'
+30 ;JRA IB*2.0*592
NEW FT
SET FT=$$FT^IBCEF(IB399)
+31 ;JRA IB*2.0*592
IF (FT=2!(FT=7))
IF $GET(IBID(IBNET))=""
IF IBTRI
IF $PIECE(IBZ1,U,IBSEQ)
Begin DoDot:1
+32 if $PIECE(IBZ,U,IBPRTYP)=""
QUIT
+33 ; here, no network id & TRICARE ins co.
+34 NEW Z
+35 SET Z=+$ORDER(^DGCR(399,IB399,"PRV","B",IBPRTYP,0))
SET Z=$PIECE($GET(^DGCR(399,IB399,"PRV",Z,0)),U,2)
+36 SET IBN=IBN+1
SET IBDST(IBPRNUM,IBPRTYP,IBN)=Z_U_+$$POLICY^IBCEF(IB399,1,IBSEQ)_U_$PIECE($GET(^IBE(355.97,IBNET,0)),U,3)_U_$PIECE(IBZ,U,IBPRTYP)_U_"0^0^^^"_IBNET
End DoDot:1
+37 QUIT
+38 ;
+39 ; esg - 8/25/06 - IB*2*348 - CFIDS function
+40 ;
CFIDS(IBIFN,PRVTYP,ALLOWIDS) ; Claim Form IDs for human providers
+1 ; Function returns a 3 piece string: [1] default secondary ID qual
+2 ; [2] default secondary ID
+3 ; [3] NPI
+4 ; Input: IBIFN - internal claim#
+5 ; PRVTYP - internal provider type ID number
+6 ; - 1:REFER;2:OPER;3:REND;4:ATT;5:SUPER;9:OTHER
+7 ; - if blank, then default Att/Rend based on form type
+8 ; ALLOWIDS - List of allowable Secondary IDS ^ delimited.
+9 ; ex "^1A^1B^1C^1H^G2^LU^N5^"
+10 ; UB-04 only wants IDs provided by the payer, not the providers own IDS
+11 ; Also, they want the qualifier to be G2 (Commercial)
+12 ; if it is a payer provided ID
+13 NEW ID,FT,IBZ,IBQ,IBSID,IBNPI,I,OK
+14 SET ID=""
+15 IF '$GET(IBIFN)
GOTO CFIDSX
+16 SET FT=$$FT^IBCEF(IBIFN)
+17 IF '$GET(PRVTYP)
SET PRVTYP=3
IF FT=3
SET PRVTYP=4
+18 DO ALLIDS^IBCEF75(IBIFN,.IBZ,1)
+19 SET OK=0
IF $GET(ALLOWIDS)=""
SET OK=1
+20 FOR I=1:1
Begin DoDot:1
+21 ; qualifier
SET IBQ=$PIECE($GET(IBZ("PROVINF",IBIFN,"C",1,PRVTYP,I)),U,3)
+22 ; ID#
SET IBSID=$PIECE($GET(IBZ("PROVINF",IBIFN,"C",1,PRVTYP,I)),U,4)
+23 IF IBQ=""
IF IBSID=""
SET OK=1
QUIT
+24 if OK
QUIT
+25 IF $GET(ALLOWIDS)[(U_IBQ_U)
SET OK=1
SET IBQ="G2"
QUIT
+26 SET (IBQ,IBSID)=""
End DoDot:1
if OK
QUIT
+27 SET IBNPI=""
+28 DO F^IBCEF("N-PROVIDER NPI CODES","IBNPI",,IBIFN)
+29 ; NPI
SET IBNPI=$PIECE(IBNPI,U,PRVTYP)
+30 ;
+31 ; special check for the referring doc
+32 IF PRVTYP=1
IF $DATA(IBZ("PROVINF",IBIFN,"C",1,PRVTYP))
IF IBQ=""
IF IBSID=""
SET IBQ="1G"
SET IBSID="VAD000"
+33 ;
+34 ; If UB-04 and no IDs, use VA UPIN as deafult
+35 IF $DATA(IBZ("PROVINF",IBIFN,"C",1,PRVTYP))
IF FT=3
IF IBQ=""
IF IBSID=""
SET IBQ="1G"
SET IBSID="VAD000"
+36 ;
+37 ; determine if legacy ID's should be displayed
+38 IF '$$PRTLID(IBIFN,IBNPI)
SET (IBQ,IBSID)=""
+39 ;
+40 SET ID=IBQ_U_IBSID_U_IBNPI
CFIDSX ;
+1 QUIT ID
+2 ;
DOL(AMT,LEN,DEC) ; format dollar amounts for printed claim forms
+1 ; AMT = amount to be formatted
+2 ; LEN = length of field - right justified to this length
+3 ; DEC = flag to include the decimal point or not
+4 ; DEFAULT value is to not include the decimal point
+5 ; if DEC is not defined or 0, assume no decimal point
+6 ; so 15 will be returned as 1500, 6.77 will be returned as 677
+7 ; if DEC is 1, then the decimal point will be included
+8 ;
+9 ; defaults
SET LEN=$GET(LEN,10)
SET DEC=$GET(DEC,0)
+10 ; format # with 2 decimals
SET AMT=$FNUMBER(+$GET(AMT),"",2)
+11 ; strip or leave decimal
IF 'DEC
SET AMT=$TRANSLATE(AMT,".")
+12 ; right justify
SET AMT=$JUSTIFY(AMT,LEN)
+13 QUIT AMT
+14 ;
PRTLID(IBIFN,NPI) ; YMG; Print Legacy IDs on the CMS-1500 or UB-04 form
+1 ; Function fetches form type associated with given claim number
+2 ; (values: 2 - CMS-1500 form, 3 - UB-04 form), then looks at
+3 ; "Print Legacy ID" site parameter for this particular form type.
+4 ;
+5 ; Possible site parameter values are:
+6 ; "Y" - always print Legacy ID
+7 ; "N" - never print Legacy ID
+8 ; "C" - only print Legacy ID if NPI is not available.
+9 ;
+10 ; This information is used to determine if Legacy ID should be printed
+11 ; for claim number in question.
+12 ;
+13 ; Note: Situation when "Print Legacy ID" site parameter is not set is treated
+14 ; as if this parameter was set to "Y" - always print Legacy ID.
+15 ;
+16 ; Input:
+17 ; IBIFN - internal claim number
+18 ; NPI - NPI number (or "" if no NPI is available)
+19 ;
+20 ; Returns:
+21 ; 0 - Legacy ID should not be printed
+22 ; 1 - Legacy ID should be printed
+23 ;
+24 ;JRA IB*2.0*592 Treat Dental Form 7 (J430D) same as CMS-1500 - added 'FT'
+25 ;Q $S(NPI="":"YC",1:"Y")[$P($G(^IBE(350.9,1,1)),U,$S($$FT^IBCEF(IBIFN)=2:32,1:33)) ;JRA IB*2.0*592 ';'
+26 ;JRA IB*2.0*592
NEW FT
SET FT=$$FT^IBCEF(IBIFN)
+27 ;JWS;IB*2.0*592 - NO legacy id's for dental
+28 IF FT=7
QUIT 0
+29 ;JRA IB*2.0*592
QUIT $SELECT(NPI="":"YC",1:"Y")[$PIECE($GET(^IBE(350.9,1,1)),U,$SELECT(FT=2:32,1:33))
+30 ;
+1 ; for claim IBIFN. Data pulled from field# 402 of file 399 and
+2 ; formatted into an array IBXDATA(n) where each line is not greater
+3 ; than 24 characters long. This will fit into UB-04 FL-80.
+4 ;
+5 ; OFLG=1 only when called in the output formatter. In this case, only
+6 ; 4 lines in IBXDATA will be returned.
+7 ;
+8 NEW TEXT,LEN,IBZ,J,PCE,CHS,NEWCHS,IBK,J,TX,IBCP1
+9 KILL IBXDATA
+10 ;
+11 ; MRD;IB*2.0*516 - Pull the Bill Remarks for the claim. If this was
+12 ; called from the Output Formatter, then look at lines of claim for
+13 ; NDC's. If any are found, they should be added to the end of TEXT.
+14 ;
+15 SET TEXT=$PIECE($GET(^DGCR(399,+$GET(IBIFN),"UF2")),U,3)
+16 ; VAD/ Begin of IB*2*577 changes
+17 ; NDC, Quantity, and Unit of Measure now printed in FL-43
+18 ; instead of here in FL-80
+19 ;I $G(OFLG) D
+20 ;. S J=0
+21 ;. F S J=$O(^DGCR(399,+$G(IBIFN),"CP",J)) Q:'J S IBCP1=$G(^(J,1)) I $P(IBCP1,U,7)'="" D
+22 ;. . I TEXT'="" S TEXT=TEXT_" "
+23 ;. . S TEXT=TEXT_"N4"_$TR($P(IBCP1,U,7),"-")_" UN"_$P(IBCP1,U,8)
+24 ;. . Q
+25 ;. Q
+26 ; VAD/ End of IB*2*577 changes
+27 ;
+28 ; If there's nothing in TEXT, then Quit.
+29 ;
+30 IF TEXT=""
QUIT
+31 ;
+32 ; need to break up large words for word wrapping purposes to get
+33 ; as many characters as possible in the box.
+34 SET LEN=17
+35 FOR PCE=1:1
if PCE>$LENGTH(TEXT," ")
QUIT
SET CHS=$PIECE(TEXT," ",PCE)
IF $LENGTH(CHS)>LEN
Begin DoDot:1
+36 SET NEWCHS=$EXTRACT(CHS,1,LEN)_" "_$EXTRACT(CHS,LEN+1,999)
+37 SET $PIECE(TEXT," ",PCE)=NEWCHS
+38 QUIT
End DoDot:1
+39 ;
+40 ; When calling FSTRNG^IBJU1 which calls ^DIWP, FileMan builds the
+41 ; array with strings of max length=1 less than what you tell it.
+42 ;
+43 ; line 1 is 19 chars
SET LEN=20
+44 ; build IBZ array
DO FSTRNG^IBJU1(TEXT,LEN,.IBZ)
+45 ; save off the first line
SET IBK=$$TRIM^XLFSTR($GET(IBZ(1)))
+46 ; restore the rest of the text
SET TEXT=$PIECE(TEXT,IBK,2,99)
+47 ; trim spaces
SET TEXT=$$TRIM^XLFSTR(TEXT)
+48 ;
+49 ; the rest is 24 chars
SET LEN=25
+50 ; build IBZ array
DO FSTRNG^IBJU1(TEXT,LEN,.IBZ)
+51 ; line 1
SET IBXDATA(1)=" "_IBK
+52 ; lines 2-n
SET J=0
FOR
SET J=$ORDER(IBZ(J))
if 'J
QUIT
Begin DoDot:1
+53 ; only 4 lines for output formatter
IF J>3
IF $GET(OFLG)
QUIT
+54 SET TX=$$TRIM^XLFSTR($GET(IBZ(J)))
+55 IF TX'=""
SET IBXDATA(J+1)=TX
+56 QUIT
End DoDot:1
+57 QUIT
+58 ;
B43(NDCDATA) ; This is passed a string and properly formats if there is NDC drug information.
+1 ; The drug information is in pieces 21-23 of that string.
+2 ; It was part of the output formatter entry 364.7[1406] used for FL43 but that got too big for a FileMan Mumps data element
+3 ; It returns a string with N4 - the NDC Drug qualifier
+4 ; NDC Code without the hyphens
+5 ; a space
+6 ; Units qualifier
+7 ; Units
+8 ; Ex "N412345678901 ML1.5"
+9 IF NDCDATA=""
QUIT ""
+10 SET NDCDATA=$PIECE(NDCDATA,U,21,23)
+11 if $PIECE(NDCDATA,U)=""
QUIT ""
+12 QUIT "N4"_$TRANSLATE($PIECE(NDCDATA,U),"-")_" "_$TRANSLATE($PIECE(NDCDATA,U,2,3),U)
+13 ;
