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

IBCEF2.m

Go to the documentation of this file.
  1. IBCEF2 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;8/6/03 10:54am
  1. ;;2.0;INTEGRATED BILLING;**52,85,51,137,232,155,296,349,403,400,432,488,461,547,592,608,665**;21-MAR-94;Build 28
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. HOS(IBIFN) ; Extract rev codes for inst. episode into IBXDATA
  1. ; Moved for space
  1. D HOS^IBCEF22(IBIFN)
  1. Q
  1. ;
  1. OTHINS(IBIFN) ;Determine 'other insurance' node (I1,I2)
  1. ; If primary bill, other ins is secondary
  1. ; If sec or tert bill, other ins is primary
  1. ;IBIFN = bill ien
  1. N Z
  1. S Z=$$COBN^IBCEF(IBIFN)
  1. Q "I"_$S(Z=1:2,1:1)
  1. ;
  1. OTHINS1(IBIFN) ; Returns the COB #'s of all 'other insurance' as a string
  1. ;IBIFN = bill ien
  1. N IBC,Z
  1. S Z=$$COBN^IBCEF(IBIFN)
  1. I Z=1 S IBC=$S($D(^DGCR(399,IBIFN,"I2")):$S($D(^DGCR(399,IBIFN,"I3")):23,1:2),1:"") ;Primary=>2 or 23
  1. I Z=2 S IBC="1"_$S($D(^DGCR(399,IBIFN,"I3")):3,1:"") ;Secondary=>1 or 13
  1. I Z=3 S IBC="12" ;Tertiary =>12
  1. OTHQ Q IBC
  1. ;
  1. RECVR(IBIFN) ; Returns the V.A. internal routing id of the current ins
  1. ; co for 837
  1. ;IBIFN = bill ien
  1. N MCR,NUM,IBPH
  1. ;JWS;IB*2.0*592:Dental form #7
  1. S IBPH=$P("P^H^^^^DENTAL",U,$$FT^IBCEF(IBIFN)-1)
  1. S NUM=$S($$FT^IBCEF(IBIFN)=7:IBPH,1:"ENVOY"_IBPH)
  1. ; If rate type is CHAMPVA, send 'CHAMVA'
  1. I $P($G(^DGCR(399.3,+$P($G(^DGCR(399,IBIFN,0)),U,7),0)),U)="CHAMPVA" S NUM="CHAMV"_IBPH
  1. I NUM["ENVOY",$$MCRWNR^IBEFUNC(+$$CURR(IBIFN)) D
  1. . ;JWS;IB*2.0*592:Dental form #7
  1. . S MCR=$P("B^A^^^^B",U,$$FT^IBCEF(IBIFN)-1) ; PART A/B for MEDICARE
  1. . S NUM="PART"_MCR
  1. Q NUM
  1. ;
  1. ALLPAYID(IBIFN,IBXDATA,SEQ) ; Returns clearinghouse id for all (SEQ="")
  1. ; or a specific (SEQ=1,2,3) ins co's for 837 in IBXDATA(n) for bill ien
  1. ; IBIFN
  1. ; EJK *296* Add IBMRA - MRA Claim type.
  1. ; EJK *296* Add IBEBI - Electronic Billing ID
  1. ;
  1. ;WCJ;IB*2.0*547 - added IBM2
  1. ;N Z,Z0,Z1,A,IBM,IBINST,IBMCR,IBX,IBMRA,IBEBI
  1. N Z,Z0,Z1,A,IBM,IBM2,IBINST,IBMCR,IBX,IBMRA,IBEBI
  1. ;S IBXDATA="",IBM=$G(^DGCR(399,IBIFN,"M"))
  1. S IBXDATA="",IBM=$G(^DGCR(399,IBIFN,"M")),IBM2=$G(^DGCR(399,IBIFN,"M2"))
  1. F Z=1:1:3 I $S('$G(SEQ):1,1:Z=SEQ) S Z0=$P(IBM,U,Z) I Z0 D S:A'="" IBXDATA(Z)=A
  1. . S A=""
  1. . ;WCJ;IB*2.0*547
  1. . I $P(IBM2,U,Z*2)]"" S A=$P(IBM2,U,Z*2) Q ; grab new alternate payer IDs from bill if they exist
  1. . ;
  1. . S IBINST=($$FT^IBCEF(IBIFN)=3) ;Is bill UB-04?
  1. . ; EJK *296* Get IBEBI based on Prof. or Inst. claim
  1. . I IBINST S IBEBI=$P($G(^DIC(36,Z0,3)),U,4)
  1. . I 'IBINST S IBEBI=$P($G(^DIC(36,Z0,3)),U,2)
  1. . ;JWS;IB*2.0*592;Dental payer id;IA# 5292
  1. . I $$FT^IBCEF(IBIFN)=7 S IBEBI=$P($G(^DIC(36,Z0,3)),U,15)
  1. . S IBEBI=$$UP^XLFSTR(IBEBI)
  1. . ; EJK *296* If this is a Medicare claim, it may be printed or transmitted.
  1. . S IBMRA=$$MRASEC^IBCEF4(IBIFN) ;Is claim 2ndary to an MRA?
  1. . S IBMCR=$$MCRONBIL^IBEFUNC(IBIFN),Z1=$G(^DGCR(399,IBIFN,"TX"))
  1. . Q:$P(Z1,U,8)=1!$S('$P(Z1,U,9):0,1:$$MRASEC^IBCEF4(IBIFN)) ;Force local prnt
  1. . ;JWS;IB*2.0*592;9/1/17 add Dental Payer ID;IA# 5292
  1. . S A=$S($P(Z1,U,8)'=2:$P($G(^DIC(36,Z0,3)),U,$S(IBINST:4,$$FT^IBCEF(IBIFN)=7:15,1:2)),1:"")
  1. . S A=$$UP^XLFSTR(A)
  1. . ;
  1. . ; RPRNT = CMS-1500 Rx bills
  1. . ; IPRNT = Inst MRA secondary claims
  1. . ; PPRNT = Prof MRA secondary claims
  1. . ; HPRNT = inst printed bills (non-MRA, force print at clearinghouse)
  1. . ; SPRNT = prof printed bills (non-MRA, force print at clearinghouse)
  1. . ;
  1. . ; Default to appropriate 'xPRNT' if Rx bill or COB bill or forced to
  1. . ; print - claims must print at clearinghouse
  1. . ;
  1. . ; Rx bills on CMS-1500
  1. . ;IB*2.0*432/TAZ Claims no longer print at clearinghouse
  1. . ;I 'IBINST,$$ISRX^IBCEF1(IBIFN) S A="RPRNT" Q
  1. . ;
  1. . ; Claim forced to print at clearinghouse (Field #27)
  1. . I $P(Z1,U,8)=2 S A=$S(IBINST:"H",1:"S")_"PRNT" Q
  1. . ;
  1. . ; EJK *296* Send IBEBI for MRA secondary claims if it exists
  1. . I Z>1,IBMRA,IBEBI'="" S A=IBEBI Q
  1. . ;
  1. . ;WCJ;IB*2.0*665;It was making LCOB not match OI6 for secondary payer on teriary claims
  1. . ; MRA secondary claim
  1. . ; I Z>1,IBMCR=1,$P(Z1,U,5)="C" S A=$S(IBINST:"I",1:"P")_"PRNT" Q
  1. . ;
  1. . ; Medicare is current payer (MRA request claim)
  1. . I $$WNRBILL^IBEFUNC(IBIFN,Z) S A=$S(IBINST:"12M61",1:"SMTX1") Q
  1. . ;
  1. . ; IB*296 - Do not modify the payer ID for CHAMPVA (HAC)
  1. . I A=84146 Q
  1. . I A=84147 Q
  1. . ;
  1. . ; If not a primary bill force to print
  1. . ;IB*2.0*432/TAZ secondary bills will now be processed
  1. . ;I Z>1,Z=$$COBN^IBCEF(IBIFN) S A=$S(IBINST:"H",1:"S")_"PRNT" Q
  1. . Q
  1. ;
  1. Q
  1. ;
  1. PAYERID(IBIFN) ; Returns clearinghouse id for current ins co
  1. ; IBIFN = bill ien
  1. N NUM,IBSEQ
  1. ; Determine the current ins co's # to identify at WEBMD
  1. ; Envoy changed to WEBMD in patch 232
  1. S IBSEQ=+$$COBN^IBCEF(IBIFN)
  1. D ALLPAYID(IBIFN,.NUM,IBSEQ) S NUM=$G(NUM(IBSEQ))
  1. Q $G(NUM)
  1. ;
  1. CURR(IBIFN) ; Returns ien of the current insurance
  1. ; company for bill ien IBIFN
  1. Q $$FINDINS^IBCEF1(IBIFN)
  1. ;
  1. ADMDT(IBIFN,NOOUTCK) ; Calculate admission/start of care date/time
  1. D ADMDT^IBCEF21(IBIFN,$G(NOOUTCK)) ; Moved for space
  1. Q
  1. ;
  1. DISDT(IBIFN) ; Calculate discharge date
  1. D DISDT^IBCEF21(IBIFN) ; Moved for space
  1. Q
  1. ;
  1. INDTS(IBIFN) ; Function returns the admit ^ discharge date/time of admission if patient is an inpatient on bill's event date
  1. N Z,Z0,DFN,VAINDT,VAIN S Z0=""
  1. S Z=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(Z,U,2),VAINDT=$P(Z,U,3)
  1. I +DFN,+VAINDT D INP^VADPT I +VAIN(1) S Z0=+VAIN(7)_U_+$G(^DGPM(+$P($G(^DGPM(+VAIN(1),0)),U,17),0))
  1. Q Z0
  1. ;
  1. TXMT(IBIFN) ; Function moved - use new call in IBCEF4
  1. Q $$TXMT^IBCEF4(IBIFN)
  1. ;
  1. ;
  1. ID(LN,VAL) ; Set EXTRACT GLOBAL for multi-valued record
  1. ; ids for Austin
  1. ; LN = the line # being extracted
  1. ; VAL = the value of the element being extracted
  1. ;
  1. ; Assumes IBXPG exists
  1. ;
  1. Q:LN<2
  1. D SETGBL^IBCEFG(IBXPG,LN,1,VAL,.IBXSIZE)
  1. Q
  1. ;
  1. ID1(LN,DX,CT,DCT,ECT) ;Special entry point for diagnoses to 'save' the fact
  1. ; a dx code is an e-code.
  1. ; LN is last entry # output, returned as the entry # (IBXLINE) to assign to this entry
  1. ; DX = the actual Dx code array(RECORD ID). Pass by reference, DX returned null if
  1. ; dx was not output
  1. ; CT = the ct on the 'DC' entry. pass by reference, returned null if
  1. ; the end of the valid dx codes has been reached
  1. ; DCT= Count of regular DX codes. UB-04 can have 25 non External Cause codes.
  1. ; ECT= Count of External Cause codes. UB-04 can have 12 External Cause codes.
  1. ; External Cause of Injury codes and qualifier changed with ICD-10: E-codes in ICD-9, V,X,W,Y-codes in ICD-10
  1. N IBINS,VAL,CNT,DXIEN,DXQ,EDX,I,POA,ICDV
  1. S IBINS=($$FT^IBCEF(IBXIEN)=3)
  1. S VAL="DC"_CT
  1. S VAL=$E(VAL_" ",1,4)
  1. S DCT=+$G(DCT),ECT=+$G(ECT) ;Make sure variables are initialized.
  1. ;
  1. S EDX=0,DX=$G(DX)
  1. S ICDV=$$ICD9VER^IBACSV(+$G(DX(CT)))
  1. I ICDV=1,$E(DX)="E" S EDX=1 ; TRUE if ECI ICD-9 Dx (e-code)
  1. I ICDV=30,"VWXY"[$E(DX) S EDX=1 ; TRUE if ECI ICD-10 Dx
  1. ;
  1. S I=$S(EDX:3,1:2)
  1. ;
  1. S:'EDX DXQ=$S(+$G(^TMP("DCX",$J,2))>0:"BF",1:"BK") ; first non e-code DX is principal (qualifier "BK"), the rest have qualifier "BF"
  1. ;
  1. I IBINS D I DX="" G IDX1
  1. .;I CT>28 S CT="" Q ; Max of 28 codes for institutional/UB
  1. .I EDX S ECT=ECT+1 I ECT>12 S DX="" Q ;Only 12 E-codes allowed
  1. .I 'EDX S DCT=DCT+1 I DCT>25 S DX="" Q ;Only 25 DX codes allowed
  1. .S DXIEN=$P(DX(CT),U,2) Q:DXIEN=""
  1. .; IB*2.0*547 - no longer stuff a 1 for POA, send a blank if null
  1. .S POA=$P($G(^IBA(362.3,DXIEN,0)),U,4) ; I POA="",$$INPAT^IBCEF(IBXIEN) S POA=1 ; POA indicator defaults to "1", if not present on inpatient claim
  1. .S:EDX DXQ="BN" ; e-code DX qualifier
  1. .Q
  1. ;
  1. I 'IBINS S:EDX DXQ="BF" S POA="" ; on CMS-1500 e-code DX qualifiers are "BF" and there's no POA
  1. ;
  1. I ICDV=30 S DXQ="A"_DXQ ; adjust Qualifier for ICD-10 codes
  1. ;
  1. ;Changed 8 to 12 so we can transmit 12 codes. BAA *488*
  1. I 'IBINS,CT>12 S ^TMP("IBXSAVE",$J,"DX",IBXIEN)=$G(^TMP("IBXSAVE",$J,"DX",IBXIEN))+1,^TMP("IBXSAVE",$J,"DX",IBXIEN,$P(DX(+^TMP("IBXSAVE",$J,"DX",IBXIEN)),U,2))=$G(^TMP("IBXSAVE",$J,"DX",IBXIEN)) S DX="" Q
  1. ;
  1. I CT'="",DX'="" D
  1. .; populate ^TMP("DCX") scratch global
  1. .S ^TMP("DCX",$J,1)=CT,CNT=$G(^TMP("DCX",$J,I))+1,^TMP("DCX",$J,I)=CNT
  1. .S (^TMP("DCX",$J,I,CNT),^TMP("DCX",$J,1,CT))=DX_U_DXQ_U_POA
  1. .S LN=LN+1 D ID(LN,VAL) S ^TMP("IBXSAVE",$J,"DX",IBXIEN,$P(DX(LN),U,2))=LN,^TMP("IBXSAVE",$J,"DX",IBXIEN)=CT,CT=CT+1
  1. .Q
  1. ;
  1. IDX1 ;
  1. Q
  1. ;
  1. M(CT) ; Calculate multi-valued field for 837 extract
  1. ; CT = passed by reference/the record ID counter
  1. S CT=CT+1
  1. ;IB*2.0*547/TAZ Increase counter to 25
  1. ;Q $E(CT#12+$S(CT#12:0,1:12)_" ",1,2)
  1. ;IB*2.0*665v1;JWS;4/1/21;Do not mod CT with any value, just return count
  1. ;;Q $E(CT#25+$S(CT#25:0,1:25)_" ",1,2)
  1. Q CT
  1. ;
  1. SVITM(IBA,LINE) ; Saves the linked items from the bill data extract into
  1. ; an array the formatter will use to link Rxs and prosthetics
  1. ; to an SV1 or SV2 line item, if possible. Kills off IBA array entries
  1. ; after they are 'moved'
  1. ; IBA = array that contains the data to be saved
  1. ; subscripts are (line #,item type,item pointer)=ct
  1. N Z0,Z1
  1. S Z0="" F S Z0=$O(IBA("OUTPT",LINE,Z0)) Q:Z0="" I Z0?1N.N S Z1="" F S Z1=$O(IBA("OUTPT",LINE,Z0,Z1)) Q:Z1="" S ^TMP($J,"IBITEM",Z0,Z1,LINE)=IBA("OUTPT",LINE,Z0,Z1) K IBA("OUTPT",LINE,Z0,Z1)
  1. Q
  1. ;
  1. ; IBTYP = the code for the type of item
  1. ; returned incremented if no link is made
  1. ; IBDATA = the extracted data string that identifies the item.
  1. ; Returns the line to link to or null if no link
  1. N IBLN,IBKEY,Z
  1. S IBLN=""
  1. S IBKEY=$S(IBTYP=3:$P(IBDATA,U,9),IBTYP=5:$P(IBDATA,U,4),1:"") Q:IBKEY=""
  1. I $D(^TMP($J,"IBITEM",IBTYP,IBKEY)) D G:IBLN LINKQ
  1. .S Z=0 F S Z=$O(^TMP($J,"IBITEM",IBTYP,IBKEY,Z)) Q:'Z I ^TMP($J,"IBITEM",IBTYP,IBKEY,Z) S IBLN=Z,^TMP($J,"IBITEM",IBTYP,IBKEY,Z)=^TMP($J,"IBITEM",IBTYP,IBKEY,Z)-1 Q
  1. I $D(^TMP($J,"IBITEM",IBTYP,0)) S IBKEY=0 D
  1. .S Z=0 F S Z=$O(^TMP($J,"IBITEM",IBTYP,IBKEY,Z)) Q:'Z I ^TMP($J,"IBITEM",IBTYP,IBKEY,Z) S IBLN=Z,^TMP($J,"IBITEM",IBTYP,IBKEY,Z)=^TMP($J,"IBITEM",IBTYP,IBKEY,Z)-1 Q
  1. LINKQ Q IBLN
  1. ;
  1. COID(IBIFN) ; Claim office ID - moved for space
  1. Q $$COID^IBCEF21(IBIFN)
  1. ;
  1. PPOL(IBIFN,COB) ; return IFN of patient policy on a bill defined by COB (fields 399,112-114)
  1. N X,Y,PPOL S PPOL=""
  1. I +$G(IBIFN) S X=$G(^DGCR(399,+IBIFN,"M")) I +$G(COB),COB<4 S Y=COB+11,PPOL=$P(X,U,Y)
  1. Q PPOL
  1. ;
  1. LADJ(SUB,LINE,SEQ1,GRP,IBXSAVE,PIECE) ; Extract line level adjustments
  1. ; SUB = 1st subscript in IBXSAVE array to use
  1. ; LINE = 2nd subscript
  1. ; SEQ1 = 4th subscript
  1. ; GRP = 5th subscript
  1. ; IBXSAVE = array that has the data for COB line level adjustments
  1. ; PIECE = # of the piece on the 0-node of the line level
  1. ; adjustment reason to be extracted
  1. ;
  1. N A,B
  1. S (A,B)=0
  1. F S A=$O(IBXSAVE(SUB,LINE,"COB",SEQ1,GRP,A)) Q:'A D
  1. . S B=B+1,IBXDATA(B)=$P(IBXSAVE(SUB,LINE,"COB",SEQ1,GRP,A),U,PIECE)
  1. Q
  1. ;
  1. ESGHPST(IBIFN,COB) ; return insureds employ status if bill policy defined by COB is an Employer Sponsored Group Health Plan
  1. Q $$ESGHPST^IBCEF21(IBIFN,COB) ;Tag moved
  1. ;
  1. ESGHPNL(IBIFN,COB) ; return employer name and location if bill policy defined by COB is an Employer Sponsored Group Health Plan
  1. Q $$ESGHPNL^IBCEF21(IBIFN,COB) ;Tag moved
  1. ;
  1. AMTOUT(A,B,C,IBXSAVE) ; format output amount
  1. ;
  1. N Z,K,IBZ,IBARR K IBXDATA S (IBZ,K)=0,IBARR="IBXSAVE("""_A_""")" F S IBZ=$O(@IBARR@(IBZ)) Q:'IBZ S K=K+1,Z=0 F S Z=$O(@IBARR@(IBZ,Z)) Q:'Z I $P($G(@IBARR@(IBZ,Z,B)),U,C) S IBXDATA(K)=$$DOLLAR^IBCEFG1($G(IBXDATA(K))+$P(@IBARR@(IBZ,Z,B),U,C))
  1. Q
  1. ;
  1. ;/Beginning of IB*2.0*608 (US9) - vd
  1. SNF(IBIFN) ; Check to see if the claim is a SNF (Skilled Nursing Facility) Claim.
  1. ; Returned Values:
  1. ; SNF = 0 if claim is not a SNF Claim.
  1. ; SNF = 1 if claim is a SNF Claim.
  1. N SNF
  1. S SNF=0
  1. I $$GET1^DIQ(399,IBIFN_", ",.24,"I")=2 S SNF=1 ; Claim is a SNF Claim
  1. Q SNF
  1. ;
  1. VC80CK(IBIFN) ; Determine if the Claim is eligible for Value Code 80 Revenue Code Claim Lines.
  1. N BLTYPX,COB,IB0,NUM,PPAYID,RCVRID,VC80SW
  1. S VC80SW=0
  1. I '$$SNF(IBIFN) Q VC80SW ; Not a SNF Claim.
  1. S RCVRID=$$RECVR^IBCEF2(IBIFN) I "^ENVOYH^PARTA^"'[(U_RCVRID_U) Q VC80SW ; Not ENVOYH or PARTA
  1. S COB=$$COB^IBCEF(IBIFN) I COB'="P" Q VC80SW ; Payer Responsibility Sequence not equal to "P".
  1. D ALLPAYID(IBIFN,.NUM,1) S PPAYID=$G(NUM(1)) Q:(PPAYID'="12M61") VC80SW ; Primary Payer not equal to "12M61"
  1. S IB0=$G(^DGCR(399,IBIFN,0))
  1. S BLTYPX=$P(IB0,U,24)_$P(IB0,U,5)
  1. I BLTYPX<21!(BLTYPX>23) Q VC80SW ; Not a valid Bill Type.
  1. S VC80SW=1 ; If we got this far.the claim is eligible for Value Code 80 Revenue Code Claim Lines.
  1. Q VC80SW
  1. ;
  1. INS ; Called by the Output Formatter [#364.7, 176]
  1. N A,Z
  1. S Z=0,A=$G(^TMP($J,"IBLCT"))
  1. F S Z=$O(IBXDATA(Z)) D Q:'Z
  1. . K:'Z&($D(IBXDATA)=1) IBXDATA
  1. . S:'Z ^TMP($J,"IBLCT")=A Q:'Z
  1. . S A=A+1 M IBXSAVE("INPT",Z)=IBXDATA(Z)
  1. . K IBXDATA(Z) S IBXDATA(Z)=A
  1. . D:Z>1 ID^IBCEF2(Z,"INS ")
  1. ;
  1. I +$G(VC80) D
  1. . S Z=$O(IBXDATA(""),-1)+1
  1. . D ID^IBCEF2(Z,"INS ")
  1. . ;D VC80I^IBCEF22(A,$G(IBXSV("VC80",A))) ; Process for 'SNF' claims & the last claim line
  1. . D VC80I^IBCEF22(A) ; Process for 'SNF' claims & the last claim line.
  1. . S A=A+1
  1. . S IBXDATA(Z)=A
  1. Q
  1. ;
  1. INS05 ; Called by the Output Formatter [#364.7, 178]
  1. ;K IBXDATA S IBXNOREQ='$$REQ^IBCEF1(3,"",IBXIEN) N Z S Z=0 F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z S:$P(IBXSAVE("INPT",Z),U,4)'="" IBXDATA(Z)=$P(IBXSAVE("INPT",Z),U,4)
  1. K IBXDATA
  1. S IBXNOREQ='$$REQ^IBCEF1(3,"",IBXIEN)
  1. N LAST,Z S (LAST,Z)=0
  1. F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z D Q:LAST
  1. . I +$G(VC80) S:$O(IBXSAVE("INPT",Z))="" LAST=1,IBXDATA(Z)=$P(IBXSAVE("INPT",Z),U,4) Q:LAST
  1. . S:$P(IBXSAVE("INPT",Z),U,4)'="" IBXDATA(Z)=$P(IBXSAVE("INPT",Z),U,4)
  1. Q
  1. ;
  1. INS07 ; Called by the Output Formatter [#364.7, 181]
  1. ;N Z S Z=0 F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z S:$P(IBXSAVE("INPT",Z),U,9)'=""&($P(IBXSAVE("INPT",Z),U,2)'="") IBXSAVE("PMOD",Z)=$P(IBXSAVE("INPT",Z),U,9),IBXDATA(Z)=$P(IBXSAVE("PMOD",Z),",")
  1. N LAST,Z S (LAST,Z)=0
  1. F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z D Q:LAST
  1. . I +$G(VC80) S:$O(IBXSAVE("INPT",Z))="" LAST=1,IBXDATA(Z)="" Q:LAST
  1. . S:$P(IBXSAVE("INPT",Z),U,9)'=""&($P(IBXSAVE("INPT",Z),U,2)'="") IBXSAVE("PMOD",Z)=$P(IBXSAVE("INPT",Z),U,9),IBXDATA(Z)=$P(IBXSAVE("PMOD",Z),",")
  1. Q
  1. ;
  1. INS09 ; Called by the Output Formatter [#364.7, 180]
  1. ;K IBXDATA N Z S Z=0 F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z S IBXDATA(Z)=$S($P(IBXSAVE("INPT",Z),U,5)="":$$DOLLAR^IBCEFG1("0.00"),1:$$DOLLAR^IBCEFG1($P(IBXSAVE("INPT",Z),U,5)))
  1. K IBXDATA
  1. N LAST,Z S (LAST,Z)=0
  1. F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z D Q:LAST
  1. . I +$G(VC80) S:$O(IBXSAVE("INPT",Z))="" LAST=1,IBXDATA(Z)=0 Q:LAST
  1. . S IBXDATA(Z)=$S($P(IBXSAVE("INPT",Z),U,5)="":$$DOLLAR^IBCEFG1("0.00"),1:$$DOLLAR^IBCEFG1($P(IBXSAVE("INPT",Z),U,5)))
  1. Q
  1. ;
  1. INS12 ; Called by the Output Formatter [#364.7, 482]
  1. ;K IBXDATA N Z S Z=0 F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z S:$P(IBXSAVE("INPT",Z),U,6)'="" IBXDATA(Z)=$$DOLLAR^IBCEFG1($P(IBXSAVE("INPT",Z),U,6))
  1. K IBXDATA
  1. N LAST,Z S (LAST,Z)=0
  1. F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z D Q:LAST
  1. . I +$G(VC80) S:$O(IBXSAVE("INPT",Z))="" LAST=1,IBXDATA(Z)="" Q:LAST
  1. . S:$P(IBXSAVE("INPT",Z),U,6)'="" IBXDATA(Z)=$$DOLLAR^IBCEFG1($P(IBXSAVE("INPT",Z),U,6))
  1. Q
  1. ;
  1. INS13 ; Called by the Output Formatter [#364.7, 805]
  1. ;K IBXDATA N Z,Z0 S Z=0 F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z S:$P(IBXSAVE("INPT",Z),U)'="" Z0=$P(IBXSAVE("INPT",Z),U) S IBXDATA(Z)=$S(Z0="":"",Z0'<100&(Z0'>219):"DA",1:"UN") K:IBXDATA(Z)="" IBXDATA(Z) K IBXDATA
  1. K IBXDATA
  1. N LAST,Z,Z0 S (LAST,Z)=0
  1. F S Z=$O(IBXSAVE("INPT",Z)) Q:'Z D Q:LAST
  1. . I +$G(VC80) S:$O(IBXSAVE("INPT",Z))="" LAST=1,IBXDATA(Z)=$P(IBXSAVE("INPT",Z),U,13) Q:LAST
  1. . S:$P(IBXSAVE("INPT",Z),U)'="" Z0=$P(IBXSAVE("INPT",Z),U)
  1. . S IBXDATA(Z)=$S(Z0="":"",Z0'<100&(Z0'>219):"DA",1:"UN") K:IBXDATA(Z)="" IBXDATA(Z)
  1. Q
  1. ;/End IB*2.0*608 (US9) - vd
  1. ;