- IBCEPTC2 ;ALB/TMK - EDI PREVIOUSLY TRANSMITTED CLAIMS LIST MGR ;01/20/05
- ;;2.0;INTEGRATED BILLING;**296,320,348,349,547,592,608**;21-MAR-94;Build 90
- ;;Per VA Directive 6402, this routine should not be modified.
- ; IA 3337 for file 430.3
- ; IB*2.0*547 Variable IBLOC is pre-defined (in IBCEPTC)
- ;
- HDR ;
- K VALMHDR
- ; The following line was replaced by the subsequent couple of lines of code - (vd) IB*2*608 - US1908
- ;/IB*2*608 beginning
- ; I IBLOC S VALMHDR(1)="Claims Selected: "_+$G(^TMP("IB_PREV_CLAIM_SELECT",$J))_" (marked with *)" Q
- I IBLOC D Q
- . S VALMHDR(1)="** T = Test Claim"
- . S VALMHDR(2)="Claims Selected: "_+$G(^TMP("IB_PREV_CLAIM_SELECT",$J))_" (marked with *)"
- . Q
- ;/IB*2*608 ending
- ;
- S VALMHDR(1)="** A claim may appear multiple times if transmitted more than once. **"
- ;
- I $G(IBSORT)=1 D
- . S VALMHDR(2)="Claims Selected: "_+$G(^TMP("IB_PREV_CLAIM_SELECT",$J))_" (marked with *)"
- . Q
- ;
- I $G(IBSORT)=2 D
- . S VALMHDR(2)="** T = Test Claim ** R = Batch Rejected"
- . S VALMHDR(3)="Claims Selected: "_+$G(^TMP("IB_PREV_CLAIM_SELECT",$J))_" (marked with *)"
- . Q
- ;
- Q
- ;
- INIT ;
- S VALMCNT=0,VALMBG=1
- D BLD
- Q
- ;
- BLD ; Build display lines
- N IBDA,IBS1,IBS2,IBIFN,IB0,IBX,IBCNT,IBLEV1,IBBDA
- K ^TMP("IB_PREV_CLAIM_LIST",$J),^TMP("IB_PREV_CLAIM_SELECT",$J),^TMP("IB_PREV_CLAIM_BATCH",$J)
- S IBCNT=0
- I $O(^TMP("IB_PREV_CLAIM",$J,""))="" D G BLDQ
- . S IBX=" ** NO PREVIOUSLY "_$S(IBLOC:"PRINTED",1:"TRANSMITTED")_" CLAIMS EXIST FOR SEARCH CRITERIA SELECTED **"
- . D WRT(IBX,"",0,0,"","S","",.IBCNT,0)
- ;
- S IBS1="" F S IBS1=$O(^TMP("IB_PREV_CLAIM",$J,IBS1)) Q:IBS1="" D
- . ; First level sort
- . ; for sort by batch, display batch ID and transmit date
- . I IBSORT=1 D
- .. S IBLEV1=" Batch: "_$P(IBS1,U,2)_" Last Transmitted: "_$G(^TMP("IB_PREV_CLAIM",$J,IBS1))
- .. S IBBDA=+$O(^IBA(364.1,"B",$P(IBS1,U,2),0))
- .. I $P(IBS1,U,3) S IBLEV1=IBLEV1_" ** Test"
- .. I $P(IBS1,U,4) S IBLEV1=IBLEV1_" ** Rejected"
- .. Q
- . ;
- . ; for sort by payer, display ins co name and payer address
- . I IBSORT=2 D
- .. S IBLEV1=" "_$P(IBS1,U)_" "_$$CURRINS(+$G(^TMP("IB_PREV_CLAIM",$J,IBS1)),0)
- .. Q
- . ;
- . ; output sort header line
- . D WRT(IBLEV1,"",0,0,IBSORT,"S","",IBCNT,0) ; Add header line
- . ;
- . I IBSORT=1,IBBDA S ^TMP("IB_PREV_CLAIM_BATCH",$J,IBBDA)=VALMCNT
- . S IBS2="" F S IBS2=$O(^TMP("IB_PREV_CLAIM",$J,IBS1,IBS2)) Q:IBS2="" S IBDA=0 F S IBDA=$O(^TMP("IB_PREV_CLAIM",$J,IBS1,IBS2,IBDA)) Q:'IBDA D
- .. N IBX,IBTEST
- .. ;S IBIFN=+$G(^IBA(364,+IBDA,0)),IB0=$G(^DGCR(399,IBIFN,0))
- .. S IBIFN=$S(IBLOC:+IBDA,1:+$G(^IBA(364,+IBDA,0))),IB0=$G(^DGCR(399,IBIFN,0))
- .. S IBX=$P(^TMP("IB_PREV_CLAIM",$J,IBS1,IBS2,IBDA),U,1)
- .. I IBX=1 S IBTEST=0 ; live 364 transmission
- .. I IBX=2 S IBTEST=1 ; test 364 transmission
- .. I IBX=3 S IBTEST=1 ; test 361.4 transmission
- .. D WRT(IBS1,IBS2,IBDA,IBIFN,IBSORT,"S","",.IBCNT,0,IBTEST)
- .. I IBSORT=1,IBBDA S ^TMP("IB_PREV_CLAIM_BATCH",$J,IBBDA,VALMCNT)=IBIFN_U_IBCNT
- .. Q
- . Q
- ;
- BLDQ Q
- ;
- EXIT ; Clean up code
- ;
- K ^TMP("IB_PREV_CLAIM_LIST",$J)
- K ^TMP("IB_PREV_CLAIM_SELECT",$J)
- K ^TMP("IB_PREV_CLAIM_LIST_DX",$J)
- K ^TMP("IB_PREV_CLAIM_BATCH",$J)
- D CLEAR^VALM1
- Q
- ;
- WRT(IBS1,IBS2,IBDA,IBIFN,IBSORT,IBREP,IBHDR,IBPAGE,IBSTOP,IBTEST) ; Wrt/output
- ;
- N IBX,IB0,Z,IBCNT,ARSTAT
- S IBCNT=IBPAGE
- ;
- I 'IBIFN D G WRTQ
- . ;
- . ; for report output
- . I IBREP="R" D Q
- .. S Z="",$P(Z,"=",133)=""
- .. D SET(Z,1,IBDA,IBREP,IBHDR,1,0,.IBPAGE,.IBSTOP)
- .. D SET(IBS1,2,IBDA,IBREP,IBHDR,1,0,.IBPAGE,.IBSTOP)
- .. Q
- . ;
- . ; for ListMan screen output
- . D SET(IBS1,0,IBDA,IBREP,IBHDR,IBCNT+1,.VALMCNT,.IBPAGE,.IBSTOP)
- . Q
- ;
- S IB0=$G(^DGCR(399,IBIFN,0))
- S IBX=$$FO^IBCNEUT1($P(IB0,U,1),8) ; claim#
- S IBX=IBX_$S(IBSORT=2&$G(IBTEST):"T",1:" ")_" "
- ;JWS;IB*2.0*592 US1108 - Dental EDI 837D / form J430D
- S IBX=IBX_$S($P(IB0,U,19)=2:"1500 ",$P(IB0,U,19)=7:"J430D",1:"UB04 ")_" "
- S Z=$$INPAT^IBCEF(IBIFN) S IBX=IBX_$S(Z:"INPT ",1:"OUTPT")
- S IBX=IBX_$J($P(IB0,U,21),3)_" "
- S Z=$$EXTERNAL^DILFD(399,.13,"",$P(IB0,U,13))
- S IBX=IBX_$$FO^IBCNEUT1(Z,11)_" " ; claim status
- S ARSTAT=+$P($$BILL^RCJIBFN2(IBIFN),U,2) ; ien
- S ARSTAT=$P($G(^PRCA(430.3,ARSTAT,0)),U,2) ; abbreviation
- S IBX=IBX_$$FO^IBCNEUT1(ARSTAT,4) ; a/r status display
- ;
- I IBSORT=1 D ; sort by batch
- . N Z,IBZ,IBXDATA
- . ; Print current payer, payer address, other payers, pat name
- . D F^IBCEF("N-CURR INSURANCE COMPANY NAME","IBZ",,IBIFN)
- . S IBX=IBX_$$FO^IBCNEUT1(IBZ,25)_" " ; ins co name
- . S IBX=IBX_$$FO^IBCNEUT1($$CURRINS(IBIFN,1),29)_" " ; address
- . K IBZ D F^IBCEF("N-OTH INSURANCE CO. NAME","IBZ",,IBIFN)
- . S IBX=IBX_$$FO^IBCNEUT1($P($G(IBZ(1)),U,1),15)_" " ; other payer
- . S Z=$P($G(^DPT(+$P(IB0,U,2),0)),U,1)
- . S IBX=IBX_$E(Z,1,18) ; patient name
- . ;
- . ; set line into list
- . S IBCNT=IBCNT+1
- . D SET(.IBX,1,IBDA,IBREP,IBHDR,IBCNT,.VALMCNT,.IBPAGE,.IBSTOP)
- . S IBX=""
- . ;
- . I $G(IBZ(2))'="" D ; other payer #2 if it exists ;;IB*2.0*592 changed $J("",98) to 99
- .. S IBX=$J("",99)_$E($P(IBZ(2),U,1),1,15)
- .. D SET(.IBX,1,IBDA,IBREP,IBHDR,IBCNT,.VALMCNT,.IBPAGE,.IBSTOP)
- .. Q
- . Q
- ;
- I IBSORT=2 D ; sort by payer
- . N Z,IBZ
- . S IBX=IBX_" "
- . ; Print other payers, patient name, date last trans, batch #, reject flag
- . D F^IBCEF("N-OTH INSURANCE CO. NAME","IBZ",,IBIFN)
- . S IBX=IBX_$$FO^IBCNEUT1($P($G(IBZ(1)),U,1),18)_" " ; oth payer#1
- . S Z=$P($G(^DPT(+$P(IB0,U,2),0)),U,1)
- . S IBX=IBX_$$FO^IBCNEUT1(Z,18)_" " ; patient name
- . ;
- . S Z=+$P($G(^IBA(364,+IBDA,0)),U,2) ; Batch ptr
- . S:IBLOC IBX=IBX_$$FO^IBCNEUT1($$FMTE^XLFDT($P($G(^DGCR(399,IBIFN,"S")),U,14),"1"),17) ; date last printed *547*
- . S:'IBLOC IBX=IBX_$$FO^IBCNEUT1($$FMTE^XLFDT($P($G(^IBA(364.1,+Z,1)),U,3)\1,"1"),17) ; date last transmitted
- . S:'IBLOC IBX=IBX_$$FO^IBCNEUT1($P($G(^IBA(364.1,Z,0)),U,1),10) ; batch#
- . S:IBLOC IBX=IBX_"" ; no batch#
- . S IBX=IBX_$S($P($G(^IBA(364.1,Z,0)),U,5):" R",1:"") ; batch rejected flag
- . ;
- . ; set line into list
- . S IBCNT=IBCNT+1
- . D SET(.IBX,1,IBDA,IBREP,IBHDR,IBCNT,.VALMCNT,.IBPAGE,.IBSTOP)
- . S IBX=""
- . ;
- . I $G(IBZ(2))'="" D ; other payer#2 if it exists
- .. S IBX=$J("",45)_$E($P(IBZ(2),U),1,18)
- .. D SET(.IBX,1,IBDA,IBREP,IBHDR,IBCNT,.VALMCNT,.IBPAGE,.IBSTOP)
- .. Q
- . Q
- ;
- WRTQ I IBREP="S" S IBPAGE=IBCNT
- Q
- ;
- SET(IBX,IBLINE,IBDA,IBREP,IBHDR,IBCNT,VALMCNT,IBPAGE,IBSTOP) ;
- N Q,Z,IBZ
- S IBZ=IBX,IBX=""
- I IBREP="R" D Q
- . D:($Y+5)>IOSL!'IBPAGE HDR^IBCEPTC1(IBHDR,IBSORT,.IBPAGE,.IBSTOP) D
- . I IBLINE F Z=1:1:IBLINE W !
- . W:'IBSTOP IBZ
- . Q
- ;
- ; only display the counter if we have a line with the claim#
- S VALMCNT=VALMCNT+1
- I IBDA,$TR($E(IBZ,1,8)," ")'="" S IBZ=$$FO^IBCNEUT1($J(IBCNT,3),6)_IBZ
- I IBDA,$TR($E(IBZ,1,8)," ")="" S IBZ=" "_IBZ
- ;
- S ^TMP("IB_PREV_CLAIM_LIST",$J,VALMCNT,0)=IBZ
- S ^TMP("IB_PREV_CLAIM_LIST",$J,"IDX",VALMCNT,IBCNT)=""
- I IBDA,$TR($E(IBZ,1,8)," ")'="" S ^TMP("IB_PREV_CLAIM_LIST_DX",$J,IBCNT)=VALMCNT_U_IBDA
- Q
- ;
- CURRINS(IBIFN,TRUNC) ; Returns Current insurance address for given claim
- ; TRUNC = truncate flag; 1 to truncate the address and city
- N IBX,IBZ,L1,CITY,ST
- D F^IBCEF("N-CURR INS CO FULL ADDRESS","IBZ",,IBIFN)
- S L1=$G(IBZ(1)) I +$G(TRUNC) S L1=$E(L1,1,15)
- S CITY=$G(IBZ(4)) I +$G(TRUNC) S CITY=$E(CITY,1,10)
- S ST=$G(IBZ(5))
- I ST S ST=$P($G(^DIC(5,ST,0)),U,2)
- S IBX=L1_" "_CITY
- I CITY'="",ST'="" S IBX=IBX_","_ST
- E S IBX=IBX_" "_ST
- Q IBX
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEPTC2 7680 printed Feb 18, 2025@23:38:28 Page 2
- IBCEPTC2 ;ALB/TMK - EDI PREVIOUSLY TRANSMITTED CLAIMS LIST MGR ;01/20/05
- +1 ;;2.0;INTEGRATED BILLING;**296,320,348,349,547,592,608**;21-MAR-94;Build 90
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ; IA 3337 for file 430.3
- +4 ; IB*2.0*547 Variable IBLOC is pre-defined (in IBCEPTC)
- +5 ;
- HDR ;
- +1 KILL VALMHDR
- +2 ; The following line was replaced by the subsequent couple of lines of code - (vd) IB*2*608 - US1908
- +3 ;/IB*2*608 beginning
- +4 ; I IBLOC S VALMHDR(1)="Claims Selected: "_+$G(^TMP("IB_PREV_CLAIM_SELECT",$J))_" (marked with *)" Q
- +5 IF IBLOC
- Begin DoDot:1
- +6 SET VALMHDR(1)="** T = Test Claim"
- +7 SET VALMHDR(2)="Claims Selected: "_+$GET(^TMP("IB_PREV_CLAIM_SELECT",$JOB))_" (marked with *)"
- +8 QUIT
- End DoDot:1
- QUIT
- +9 ;/IB*2*608 ending
- +10 ;
- +11 SET VALMHDR(1)="** A claim may appear multiple times if transmitted more than once. **"
- +12 ;
- +13 IF $GET(IBSORT)=1
- Begin DoDot:1
- +14 SET VALMHDR(2)="Claims Selected: "_+$GET(^TMP("IB_PREV_CLAIM_SELECT",$JOB))_" (marked with *)"
- +15 QUIT
- End DoDot:1
- +16 ;
- +17 IF $GET(IBSORT)=2
- Begin DoDot:1
- +18 SET VALMHDR(2)="** T = Test Claim ** R = Batch Rejected"
- +19 SET VALMHDR(3)="Claims Selected: "_+$GET(^TMP("IB_PREV_CLAIM_SELECT",$JOB))_" (marked with *)"
- +20 QUIT
- End DoDot:1
- +21 ;
- +22 QUIT
- +23 ;
- INIT ;
- +1 SET VALMCNT=0
- SET VALMBG=1
- +2 DO BLD
- +3 QUIT
- +4 ;
- BLD ; Build display lines
- +1 NEW IBDA,IBS1,IBS2,IBIFN,IB0,IBX,IBCNT,IBLEV1,IBBDA
- +2 KILL ^TMP("IB_PREV_CLAIM_LIST",$JOB),^TMP("IB_PREV_CLAIM_SELECT",$JOB),^TMP("IB_PREV_CLAIM_BATCH",$JOB)
- +3 SET IBCNT=0
- +4 IF $ORDER(^TMP("IB_PREV_CLAIM",$JOB,""))=""
- Begin DoDot:1
- +5 SET IBX=" ** NO PREVIOUSLY "_$SELECT(IBLOC:"PRINTED",1:"TRANSMITTED")_" CLAIMS EXIST FOR SEARCH CRITERIA SELECTED **"
- +6 DO WRT(IBX,"",0,0,"","S","",.IBCNT,0)
- End DoDot:1
- GOTO BLDQ
- +7 ;
- +8 SET IBS1=""
- FOR
- SET IBS1=$ORDER(^TMP("IB_PREV_CLAIM",$JOB,IBS1))
- if IBS1=""
- QUIT
- Begin DoDot:1
- +9 ; First level sort
- +10 ; for sort by batch, display batch ID and transmit date
- +11 IF IBSORT=1
- Begin DoDot:2
- +12 SET IBLEV1=" Batch: "_$PIECE(IBS1,U,2)_" Last Transmitted: "_$GET(^TMP("IB_PREV_CLAIM",$JOB,IBS1))
- +13 SET IBBDA=+$ORDER(^IBA(364.1,"B",$PIECE(IBS1,U,2),0))
- +14 IF $PIECE(IBS1,U,3)
- SET IBLEV1=IBLEV1_" ** Test"
- +15 IF $PIECE(IBS1,U,4)
- SET IBLEV1=IBLEV1_" ** Rejected"
- +16 QUIT
- End DoDot:2
- +17 ;
- +18 ; for sort by payer, display ins co name and payer address
- +19 IF IBSORT=2
- Begin DoDot:2
- +20 SET IBLEV1=" "_$PIECE(IBS1,U)_" "_$$CURRINS(+$GET(^TMP("IB_PREV_CLAIM",$JOB,IBS1)),0)
- +21 QUIT
- End DoDot:2
- +22 ;
- +23 ; output sort header line
- +24 ; Add header line
- DO WRT(IBLEV1,"",0,0,IBSORT,"S","",IBCNT,0)
- +25 ;
- +26 IF IBSORT=1
- IF IBBDA
- SET ^TMP("IB_PREV_CLAIM_BATCH",$JOB,IBBDA)=VALMCNT
- +27 SET IBS2=""
- FOR
- SET IBS2=$ORDER(^TMP("IB_PREV_CLAIM",$JOB,IBS1,IBS2))
- if IBS2=""
- QUIT
- SET IBDA=0
- FOR
- SET IBDA=$ORDER(^TMP("IB_PREV_CLAIM",$JOB,IBS1,IBS2,IBDA))
- if 'IBDA
- QUIT
- Begin DoDot:2
- +28 NEW IBX,IBTEST
- +29 ;S IBIFN=+$G(^IBA(364,+IBDA,0)),IB0=$G(^DGCR(399,IBIFN,0))
- +30 SET IBIFN=$SELECT(IBLOC:+IBDA,1:+$GET(^IBA(364,+IBDA,0)))
- SET IB0=$GET(^DGCR(399,IBIFN,0))
- +31 SET IBX=$PIECE(^TMP("IB_PREV_CLAIM",$JOB,IBS1,IBS2,IBDA),U,1)
- +32 ; live 364 transmission
- IF IBX=1
- SET IBTEST=0
- +33 ; test 364 transmission
- IF IBX=2
- SET IBTEST=1
- +34 ; test 361.4 transmission
- IF IBX=3
- SET IBTEST=1
- +35 DO WRT(IBS1,IBS2,IBDA,IBIFN,IBSORT,"S","",.IBCNT,0,IBTEST)
- +36 IF IBSORT=1
- IF IBBDA
- SET ^TMP("IB_PREV_CLAIM_BATCH",$JOB,IBBDA,VALMCNT)=IBIFN_U_IBCNT
- +37 QUIT
- End DoDot:2
- +38 QUIT
- End DoDot:1
- +39 ;
- BLDQ QUIT
- +1 ;
- EXIT ; Clean up code
- +1 ;
- +2 KILL ^TMP("IB_PREV_CLAIM_LIST",$JOB)
- +3 KILL ^TMP("IB_PREV_CLAIM_SELECT",$JOB)
- +4 KILL ^TMP("IB_PREV_CLAIM_LIST_DX",$JOB)
- +5 KILL ^TMP("IB_PREV_CLAIM_BATCH",$JOB)
- +6 DO CLEAR^VALM1
- +7 QUIT
- +8 ;
- WRT(IBS1,IBS2,IBDA,IBIFN,IBSORT,IBREP,IBHDR,IBPAGE,IBSTOP,IBTEST) ; Wrt/output
- +1 ;
- +2 NEW IBX,IB0,Z,IBCNT,ARSTAT
- +3 SET IBCNT=IBPAGE
- +4 ;
- +5 IF 'IBIFN
- Begin DoDot:1
- +6 ;
- +7 ; for report output
- +8 IF IBREP="R"
- Begin DoDot:2
- +9 SET Z=""
- SET $PIECE(Z,"=",133)=""
- +10 DO SET(Z,1,IBDA,IBREP,IBHDR,1,0,.IBPAGE,.IBSTOP)
- +11 DO SET(IBS1,2,IBDA,IBREP,IBHDR,1,0,.IBPAGE,.IBSTOP)
- +12 QUIT
- End DoDot:2
- QUIT
- +13 ;
- +14 ; for ListMan screen output
- +15 DO SET(IBS1,0,IBDA,IBREP,IBHDR,IBCNT+1,.VALMCNT,.IBPAGE,.IBSTOP)
- +16 QUIT
- End DoDot:1
- GOTO WRTQ
- +17 ;
- +18 SET IB0=$GET(^DGCR(399,IBIFN,0))
- +19 ; claim#
- SET IBX=$$FO^IBCNEUT1($PIECE(IB0,U,1),8)
- +20 SET IBX=IBX_$SELECT(IBSORT=2&$GET(IBTEST):"T",1:" ")_" "
- +21 ;JWS;IB*2.0*592 US1108 - Dental EDI 837D / form J430D
- +22 SET IBX=IBX_$SELECT($PIECE(IB0,U,19)=2:"1500 ",$PIECE(IB0,U,19)=7:"J430D",1:"UB04 ")_" "
- +23 SET Z=$$INPAT^IBCEF(IBIFN)
- SET IBX=IBX_$SELECT(Z:"INPT ",1:"OUTPT")
- +24 SET IBX=IBX_$JUSTIFY($PIECE(IB0,U,21),3)_" "
- +25 SET Z=$$EXTERNAL^DILFD(399,.13,"",$PIECE(IB0,U,13))
- +26 ; claim status
- SET IBX=IBX_$$FO^IBCNEUT1(Z,11)_" "
- +27 ; ien
- SET ARSTAT=+$PIECE($$BILL^RCJIBFN2(IBIFN),U,2)
- +28 ; abbreviation
- SET ARSTAT=$PIECE($GET(^PRCA(430.3,ARSTAT,0)),U,2)
- +29 ; a/r status display
- SET IBX=IBX_$$FO^IBCNEUT1(ARSTAT,4)
- +30 ;
- +31 ; sort by batch
- IF IBSORT=1
- Begin DoDot:1
- +32 NEW Z,IBZ,IBXDATA
- +33 ; Print current payer, payer address, other payers, pat name
- +34 DO F^IBCEF("N-CURR INSURANCE COMPANY NAME","IBZ",,IBIFN)
- +35 ; ins co name
- SET IBX=IBX_$$FO^IBCNEUT1(IBZ,25)_" "
- +36 ; address
- SET IBX=IBX_$$FO^IBCNEUT1($$CURRINS(IBIFN,1),29)_" "
- +37 KILL IBZ
- DO F^IBCEF("N-OTH INSURANCE CO. NAME","IBZ",,IBIFN)
- +38 ; other payer
- SET IBX=IBX_$$FO^IBCNEUT1($PIECE($GET(IBZ(1)),U,1),15)_" "
- +39 SET Z=$PIECE($GET(^DPT(+$PIECE(IB0,U,2),0)),U,1)
- +40 ; patient name
- SET IBX=IBX_$EXTRACT(Z,1,18)
- +41 ;
- +42 ; set line into list
- +43 SET IBCNT=IBCNT+1
- +44 DO SET(.IBX,1,IBDA,IBREP,IBHDR,IBCNT,.VALMCNT,.IBPAGE,.IBSTOP)
- +45 SET IBX=""
- +46 ;
- +47 ; other payer #2 if it exists ;;IB*2.0*592 changed $J("",98) to 99
- IF $GET(IBZ(2))'=""
- Begin DoDot:2
- +48 SET IBX=$JUSTIFY("",99)_$EXTRACT($PIECE(IBZ(2),U,1),1,15)
- +49 DO SET(.IBX,1,IBDA,IBREP,IBHDR,IBCNT,.VALMCNT,.IBPAGE,.IBSTOP)
- +50 QUIT
- End DoDot:2
- +51 QUIT
- End DoDot:1
- +52 ;
- +53 ; sort by payer
- IF IBSORT=2
- Begin DoDot:1
- +54 NEW Z,IBZ
- +55 SET IBX=IBX_" "
- +56 ; Print other payers, patient name, date last trans, batch #, reject flag
- +57 DO F^IBCEF("N-OTH INSURANCE CO. NAME","IBZ",,IBIFN)
- +58 ; oth payer#1
- SET IBX=IBX_$$FO^IBCNEUT1($PIECE($GET(IBZ(1)),U,1),18)_" "
- +59 SET Z=$PIECE($GET(^DPT(+$PIECE(IB0,U,2),0)),U,1)
- +60 ; patient name
- SET IBX=IBX_$$FO^IBCNEUT1(Z,18)_" "
- +61 ;
- +62 ; Batch ptr
- SET Z=+$PIECE($GET(^IBA(364,+IBDA,0)),U,2)
- +63 ; date last printed *547*
- if IBLOC
- SET IBX=IBX_$$FO^IBCNEUT1($$FMTE^XLFDT($PIECE($GET(^DGCR(399,IBIFN,"S")),U,14),"1"),17)
- +64 ; date last transmitted
- if 'IBLOC
- SET IBX=IBX_$$FO^IBCNEUT1($$FMTE^XLFDT($PIECE($GET(^IBA(364.1,+Z,1)),U,3)\1,"1"),17)
- +65 ; batch#
- if 'IBLOC
- SET IBX=IBX_$$FO^IBCNEUT1($PIECE($GET(^IBA(364.1,Z,0)),U,1),10)
- +66 ; no batch#
- if IBLOC
- SET IBX=IBX_""
- +67 ; batch rejected flag
- SET IBX=IBX_$SELECT($PIECE($GET(^IBA(364.1,Z,0)),U,5):" R",1:"")
- +68 ;
- +69 ; set line into list
- +70 SET IBCNT=IBCNT+1
- +71 DO SET(.IBX,1,IBDA,IBREP,IBHDR,IBCNT,.VALMCNT,.IBPAGE,.IBSTOP)
- +72 SET IBX=""
- +73 ;
- +74 ; other payer#2 if it exists
- IF $GET(IBZ(2))'=""
- Begin DoDot:2
- +75 SET IBX=$JUSTIFY("",45)_$EXTRACT($PIECE(IBZ(2),U),1,18)
- +76 DO SET(.IBX,1,IBDA,IBREP,IBHDR,IBCNT,.VALMCNT,.IBPAGE,.IBSTOP)
- +77 QUIT
- End DoDot:2
- +78 QUIT
- End DoDot:1
- +79 ;
- WRTQ IF IBREP="S"
- SET IBPAGE=IBCNT
- +1 QUIT
- +2 ;
- SET(IBX,IBLINE,IBDA,IBREP,IBHDR,IBCNT,VALMCNT,IBPAGE,IBSTOP) ;
- +1 NEW Q,Z,IBZ
- +2 SET IBZ=IBX
- SET IBX=""
- +3 IF IBREP="R"
- Begin DoDot:1
- +4 if ($Y+5)>IOSL!'IBPAGE
- DO HDR^IBCEPTC1(IBHDR,IBSORT,.IBPAGE,.IBSTOP)
- Begin DoDot:2
- End DoDot:2
- +5 IF IBLINE
- FOR Z=1:1:IBLINE
- WRITE !
- +6 if 'IBSTOP
- WRITE IBZ
- +7 QUIT
- End DoDot:1
- QUIT
- +8 ;
- +9 ; only display the counter if we have a line with the claim#
- +10 SET VALMCNT=VALMCNT+1
- +11 IF IBDA
- IF $TRANSLATE($EXTRACT(IBZ,1,8)," ")'=""
- SET IBZ=$$FO^IBCNEUT1($JUSTIFY(IBCNT,3),6)_IBZ
- +12 IF IBDA
- IF $TRANSLATE($EXTRACT(IBZ,1,8)," ")=""
- SET IBZ=" "_IBZ
- +13 ;
- +14 SET ^TMP("IB_PREV_CLAIM_LIST",$JOB,VALMCNT,0)=IBZ
- +15 SET ^TMP("IB_PREV_CLAIM_LIST",$JOB,"IDX",VALMCNT,IBCNT)=""
- +16 IF IBDA
- IF $TRANSLATE($EXTRACT(IBZ,1,8)," ")'=""
- SET ^TMP("IB_PREV_CLAIM_LIST_DX",$JOB,IBCNT)=VALMCNT_U_IBDA
- +17 QUIT
- +18 ;
- CURRINS(IBIFN,TRUNC) ; Returns Current insurance address for given claim
- +1 ; TRUNC = truncate flag; 1 to truncate the address and city
- +2 NEW IBX,IBZ,L1,CITY,ST
- +3 DO F^IBCEF("N-CURR INS CO FULL ADDRESS","IBZ",,IBIFN)
- +4 SET L1=$GET(IBZ(1))
- IF +$GET(TRUNC)
- SET L1=$EXTRACT(L1,1,15)
- +5 SET CITY=$GET(IBZ(4))
- IF +$GET(TRUNC)
- SET CITY=$EXTRACT(CITY,1,10)
- +6 SET ST=$GET(IBZ(5))
- +7 IF ST
- SET ST=$PIECE($GET(^DIC(5,ST,0)),U,2)
- +8 SET IBX=L1_" "_CITY
- +9 IF CITY'=""
- IF ST'=""
- SET IBX=IBX_","_ST
- +10 IF '$TEST
- SET IBX=IBX_" "_ST
- +11 QUIT IBX
- +12 ;