- IBJTEP1 ;ALB/TJB - TP ERA/835 INFORMATION SCREEN ;01-MAY-2015
- ;;2.0;INTEGRATED BILLING;**530,633**;21-MAR-94;Build 21
- ;;Per VA Directive 6402, this routine should not be modified.
- ;; ;
- Q
- ; Utility Routine for the IBJTEP & IBJTPE routines
- EEOB(ARRAY,IENERA,KBILL,SPLIT) ; Return all of the EEOBs with this KBILL for the ERA IEN in 344.4
- N ZZ,IBZZ,CNT,IBI,IBDG,AA
- S CNT=0
- D GETS^DIQ(344.4,IENERA_",","1*;","IE","IBZZ")
- S ZZ="" F S ZZ=$O(IBZZ(344.41,ZZ)) Q:ZZ="" D:IBZZ(344.41,ZZ,.02,"E")=KBILL
- . Q:$P($G(^IBM(361.1,IBZZ(344.41,ZZ,.02,"I"),0)),U,4)=1 ; Don't count, it is a MRA
- . S CNT=CNT+1,@ARRAY@(CNT,IBZZ(344.41,ZZ,.02,"I"))=1,AA(IBZZ(344.41,ZZ,.02,"I"))=1
- . ; See if any splits are associated with this KBILL
- . D:+$G(SPLIT)'=0
- .. S IBI=0,IBDG=$$FIND1^DIC(399,,,IBZZ(344.41,ZZ,.02,"E"),"B",)
- .. I IBDG'="" F S IBI=$O(^IBM(361.1,"C",IBDG,IBI)) Q:'IBI S:$G(AA(IBI))'=1 CNT=CNT+1,@ARRAY@(CNT,IBI)=1 ; EOB has been reapportioned at the site
- S @ARRAY=CNT
- Q
- ;
- ; IEN = IEN for File 399, CODE = Revenue Code, CPT = the procedure code for this line
- ; Return the billed amount for this line
- BILLN(IEN,CODE,CPT) ; Get the line item information from the Bill
- N RCOUT,II,RET
- S RET=0
- K RCOUT D FIND^DIC(399.042,","_IEN_",",".01;.02;.03;.04;.06","",CODE,"","","","","RCOUT")
- S II="" F S II=$O(RCOUT("DILIST","ID",II)) Q:II="" I RCOUT("DILIST","ID",II,.06)=CPT S RET=RCOUT("DILIST","ID",II,.04) Q
- Q RET
- ;
- ADJU(TYPE,ARR1,END) ; Get the Deduction information from the line level
- ; TYPE = "DEDUCT" or "COINS", pass array by reference, END - quit condition
- N RCOUT,AA,BB,RET
- S RET=0
- S AA=END F S AA=$O(ARR1(361.1151,AA)) Q:$E(AA,1,$L(END))'=END D:ARR1(361.1151,AA,.01,"I")="PR"
- . S BB=AA F S BB=$O(ARR1(361.11511,BB)) Q:$E(BB,1,$L(AA))'=AA D Q:RET'=0
- .. I TYPE="DEDUCT" S:ARR1(361.11511,BB,.01,"E")=1 RET=ARR1(361.11511,BB,.02,"E") ; Deductable
- .. I TYPE="COINS" S:ARR1(361.11511,BB,.01,"E")=2 RET=ARR1(361.11511,BB,.02,"E") ; Co-Insurance
- Q RET
- ;
- RESORT(ZAR,ZIDX) ; Resort the subscripts from GETS so items collate correctly while walking the array
- ; Pass ZAR through indirection
- ; Take the second subscript and reverse the pieces, put them in right order
- Q:$G(ZIDX)']""
- N II,XX,YY,ZZ,Z1,ZN,A S ZZ="",ZN=""
- F S ZZ=$O(@ZAR@(ZIDX,ZZ)) Q:ZZ="" D
- . S ZN="" F II=1:1:($L(ZZ,",")-1) S ZN=$P(ZZ,",",II)_","_ZN
- . S XX="" F S XX=$O(@ZAR@(ZIDX,ZZ,XX)) Q:XX="" D
- .. I $D(@ZAR@(ZIDX,ZZ,XX,"E"))=1 S YY=@ZAR@(ZIDX,ZZ,XX,"E") K @ZAR@(ZIDX,ZZ,XX,"E") S QQ(ZN,XX,"E")=YY
- .. I $D(@ZAR@(ZIDX,ZZ,XX,"I"))=1 S YY=@ZAR@(ZIDX,ZZ,XX,"I") K @ZAR@(ZIDX,ZZ,XX,"I") S QQ(ZN,XX,"I")=YY
- M @ZAR@(ZIDX)=QQ
- K QQ
- Q
- ;
- RECEIPT ; Go to Receipt profile
- ; Build the ^TMP(RCDPDPLM,$J,"IDX",#,#)=# array if we have a receipt on this ERA
- ; ERALST, IBIFN is passed in by IBJTEP and will be cleaned up there
- N IBERA,IBEPB,IBRP,DIR,DTOUT,DUOUT,DZX,EPIEN,I,IX,INDEX,X,Y,IBARR,IBAR2,IBAR3,RCDEPTDA,RCRECTDA,RCDPFXIT
- D FULL^VALM1
- S VALMBCK="R"
- RC1 ;
- S IBRP(U)=", "
- I $L(ERALST,U)=1 S IBERA=ERALST G RC2
- S DIR("A")="Enter ERA for receipt review: ",DIR(0)="FA^1:10"
- S DIR("A",1)="Enter an ERA# from the following list for additional information."
- S DIR("A",2)="Available ERAs: "_$$REPLACE^XLFSTR(ERALST,.IBRP)
- D ^DIR K DIR
- I $D(DTOUT)!$D(DUOUT)!(Y="") G RCQ
- S IBERA=Y I (U_ERALST_U)'[(U_Y_U) W !!,"ERA: "_Y_" not a valid selection. Please try again...",! S X="",IBERA="" G RC1
- ;
- RC2 ;
- I $G(IBERA)="" S DIR("A",1)="No ERAs for this K-Bill exist.",DIR(0)="EA",DIR("A")="Press ENTER to continue: " W ! D ^DIR K DIR G RCQ
- ; Get zero node of ERA
- S ZN=$G(^RCY(344.4,IBERA,0))
- ; Get Reciept for this Bill
- K IBEPB,^TMP("RCDPDPLM",$J) D GETS^DIQ(344.4,IBERA_",","1*;","IE","IBEPB")
- ; No Receipt then report and quit
- I $P(ZN,U,8)="",$D(^RCY(344.4,IBERA,1,"RECEIPT"))=0 S DIR("A",1)="No receipts exist for this ERA.",DIR(0)="EA",DIR("A")="Press ENTER to continue: " W ! D ^DIR K DIR G RCQ
- ; Reciept, build temp global and call RECEIPTS
- S I=0,IX="" F S IX=$O(IBEPB(344.41,IX)) Q:IX="" I $G(IBEPB(344.41,IX,.02,"E"))=EPBILL D
- . ; Add Reciept to list if not already on this list
- . I $G(IBEPB(344.41,IX,.25,"I"))'="" S:'$D(^TMP("RCDPDPLM",$J,"RCPT",IBEPB(344.41,IX,.25,"I"))) I=I+1,^TMP("RCDPDPLM",$J,"IDX",I,I)=$G(IBEPB(344.41,IX,.25,"I")),^TMP("RCDPDPLM",$J,"RCPT",IBEPB(344.41,IX,.25,"I"))=""
- ; if no receipts, then set the single Receipt from the zero node.
- I '$D(^TMP("RCDPDPLM",$J,"IDX")) S:$P(ZN,U,8)'="" ^TMP("RCDPDPLM",$J,"IDX",1,1)=$P(ZN,U,8),^TMP("RCDPDPLM",$J,"RCPT",$P(ZN,U,8))="" I $P(ZN,U,8)="" D G RCQ
- . S DIR("A",1)="Issue with ERA: "_IBERA_" and Bill No.: "_EPBILL,DIR(0)="EA",DIR("A")="Press ENTER to continue: " W ! D ^DIR K DIR
- ;
- S RCRECTDA=$$GETRCPT($NA(^TMP("RCDPDPLM",$J,"IDX")))
- I RCRECTDA=-1 G RCQ ; no selection, "^" or read timeout
- D EN^VALM("RCDP RECEIPT PROFILE")
- ;
- RCQ ;
- ; If RCDPFXIT is set, exit option entirely was selected so quit back to the menu
- I $G(RCDPFXIT) S VALMBCK="Q"
- K ^TMP("RCDPDPLM",$J)
- Q
- ;
- GETRCPT(ARRAY) ; If only one receipt return with the single receipt, otherwise user selects receipt
- I '$O(@ARRAY@(1)) Q $S($G(@ARRAY@(1,1))'="":$G(@ARRAY@(1,1)),1:-1)
- N ZX,ZY,ZZ,ZAR,DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT,QQ
- S ZZ=0,QQ="",ZX="" F S ZX=$O(@ARRAY@(ZX)) Q:ZX="" S:QQ'="" QQ=QQ_";" S ZZ=ZZ+1,QQ=QQ_ZZ_":"_$P($G(^RCY(344,@ARRAY@(ZX,ZX),0)),U,1),ZAR(ZZ)=@ARRAY@(ZX,ZX)
- S DIR(0)="S^"_QQ
- S DIR("A")="Enter index number for Receipt" D ^DIR K DIR
- I $D(DTOUT)!$D(DUOUT)!(Y="") Q -1 ; no selection/timeout quit
- Q ZAR(Y)
- ;
- GETRX(IBIEN,IBARRY) ;return pharmacy data to about EEOB items
- ; input - IBIEN = ien to record in 361.1
- ; IBARRY = Array name that will be used to store and return pharmacy data elements
- ; output - IBARRY = holds pharmacy data
- ; IA 6033 (controlled subscription) - read access of file 362.4. status is pending
- ; ICR 1878 (supported) - usage of EN^PSOORDER
- ;
- N IB0,RXDATA,RXIEN,IBDFN,PRIEN,RXFILL
- K IBARRY
- Q:IBIEN=""
- S PRIEN=$P(^IBM(361.1,IBIEN,0),U,1) Q:PRIEN=""
- S IBDFN=$P(^PRCA(430,PRIEN,0),U,7)
- S IB0=+$O(^IBA(362.4,"C",PRIEN,0))
- Q:IB0=0
- S RXDATA=$G(^IBA(362.4,IB0,0))
- S IBARRY("DOS")=$$FMTE^XLFDT($P(RXDATA,U,3),"2Z")
- S IBARRY("FILL")=+$P(RXDATA,U,10) ; rx fill#
- S RXIEN=+$P(RXDATA,U,5) ; RX ien ptr file 52
- D EN^PSOORDER(IBDFN,RXIEN)
- S IBARRY("RX")=$P(^TMP("PSOR",$J,RXIEN,0),U,5)
- I IBARRY("FILL")=0 S IBARRY("RELEASED STATUS")=$S($P(^TMP("PSOR",$J,RXIEN,0),U,13)]"":"Released",1:"Not Released") ; Release status from Rx on the first fill (no refills)
- I IBARRY("FILL")>0 S IBARRY("RELEASED STATUS")=$S($P(^TMP("PSOR",$J,RXIEN,"REF",IBARRY("FILL"),0),U,8)]"":"Released",1:"Not Released") ; Release status from Rx refill #
- Q
- ;
- EOBREM(RCEOB,LINE) ; EP from IBJTEP - Show EOB removal details if EOB removed
- ; Input: RCEOB - Internal entry number from file 361.1
- ; LINE - Line counter for ListMan storage
- ; Output: To screen
- ; Get last move/copy history record
- N I,J,RCEOBH,RCJUST
- S RCEOBH=$O(^IBM(361.1,RCEOB,101,"A"),-1)
- ; Quit if EOB if no history found - should not occur since EOB is removed
- I 'RCEOBH D SET^IBJTEP(.LINE,"**EOB Removed**") Q
- ;
- D SET^IBJTEP(.LINE,"EOB Removed by : "_$$GET1^DIQ(361.1101,RCEOBH_","_RCEOB,.02,"E"))
- D SET^IBJTEP(.LINE,"Date/Time Removed : "_$$GET1^DIQ(361.1101,RCEOBH_","_RCEOB,.01,"E"))
- S RCJUST=$$GET1^DIQ(361.1101,RCEOBH_","_RCEOB,.03,"E")
- I $L(RCJUST>59) D ;
- . S I=1
- . F J=1:1:$L(RCJUST," ") D ;
- . . I $L($G(RCJUST(I))_$P(RCJUST," ",J))>60 S I=I+1
- . . S RCJUST(I)=$G(RCJUST(I))_" "_$P(RCJUST," ",J)
- E S RCJUST(1)=RCJUST
- D SET^IBJTEP(.LINE,"Justification :"_$G(RCJUST(1)))
- F J=2:1:I D SET^IBJTEP(.LINE," "_$G(RCJUST(J)))
- Q
- ;
- ; Make CARC or RARC description lines the right length for display - IB*2.0*633 Moved for routine size
- DLN(ZIN,ZARR,FLN,SLN) ;
- ; ZIN - array to get lines of text
- ; ZRARR - array for display passed by indirection
- ; FLN - First line length; SLN - Second and subsequent line lengths
- N ZI,ZX,ZL,ZXL,ZICT,ZCT,ZSP,ZLN
- S ZI="",ZCT=0,ZICT=0
- ; Get number of lines in array
- F S ZI=$O(@ZIN@(ZI)) Q:ZI="" S ZICT=ZICT+1
- ; If more than one line in array, process the line
- D:ZICT>1
- . S ZI="",ZL="" F S ZI=$O(@ZIN@(ZI)) Q:ZI="" S ZL=ZL_$S($L(ZL)>1:" ",1:"")_@ZIN@(ZI) D
- .. F Q:$L(ZL)<SLN S ZCT=ZCT+1 D
- ... I ZCT=1 S:$L(ZL)<FLN @ZARR@(ZCT)=ZL,ZL="" D:$L(ZL)>FLN ; First line
- .... S ZXL="" F ZX=1:1 Q:($L(ZXL)+$L($P(ZL," ",ZX)))>FLN S ZXL=ZXL_$S($L(ZXL)>0:" ",1:"")_$P(ZL," ",ZX)
- .... K ZSP S @ZARR@(ZCT)=ZXL,ZSP(ZXL)="",ZL=$$REPLACE^XLFSTR(ZL,.ZSP),ZL=$$TRIM^XLFSTR(ZL)
- ... D:ZCT>1
- .... S ZXL="" F ZX=1:1 Q:($L(ZXL)+$L($P(ZL," ",ZX)))>SLN S ZXL=ZXL_$S($L(ZXL)>0:" ",1:"")_$P(ZL," ",ZX)
- .... K ZSP S @ZARR@(ZCT)=ZXL,ZSP(ZXL)="",ZL=$$REPLACE^XLFSTR(ZL,.ZSP),ZL=$$TRIM^XLFSTR(ZL)
- . I ($L(ZL)>1) S ZCT=ZCT+1,@ZARR@(ZCT)=ZL,ZL=""
- . S @ZARR=ZCT
- ; One line in array break up if necessary
- I ZICT=1 D
- . S ZX=$O(@ZIN@(""))
- . I $L(@ZIN@(ZX))<FLN S @ZARR@(1)=@ZIN@(ZX),@ZARR=1 Q
- . ; Otherwise we are spanning two lines
- . S ZL="" F ZI=1:1 Q:($L(ZL)+$L($P(@ZIN@(ZX)," ",ZI)))>FLN S ZL=ZL_$S($L(ZL)>0:" ",1:"")_$P(@ZIN@(ZX)," ",ZI)
- . S @ZARR@(1)=ZL,@ZARR@(2)=$P(@ZIN@(ZX)," ",ZI,9999)
- . S @ZARR=2
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJTEP1 9369 printed Apr 23, 2025@18:38:28 Page 2
- IBJTEP1 ;ALB/TJB - TP ERA/835 INFORMATION SCREEN ;01-MAY-2015
- +1 ;;2.0;INTEGRATED BILLING;**530,633**;21-MAR-94;Build 21
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;; ;
- +4 QUIT
- +5 ; Utility Routine for the IBJTEP & IBJTPE routines
- EEOB(ARRAY,IENERA,KBILL,SPLIT) ; Return all of the EEOBs with this KBILL for the ERA IEN in 344.4
- +1 NEW ZZ,IBZZ,CNT,IBI,IBDG,AA
- +2 SET CNT=0
- +3 DO GETS^DIQ(344.4,IENERA_",","1*;","IE","IBZZ")
- +4 SET ZZ=""
- FOR
- SET ZZ=$ORDER(IBZZ(344.41,ZZ))
- if ZZ=""
- QUIT
- if IBZZ(344.41,ZZ,.02,"E")=KBILL
- Begin DoDot:1
- +5 ; Don't count, it is a MRA
- if $PIECE($GET(^IBM(361.1,IBZZ(344.41,ZZ,.02,"I"),0)),U,4)=1
- QUIT
- +6 SET CNT=CNT+1
- SET @ARRAY@(CNT,IBZZ(344.41,ZZ,.02,"I"))=1
- SET AA(IBZZ(344.41,ZZ,.02,"I"))=1
- +7 ; See if any splits are associated with this KBILL
- +8 if +$GET(SPLIT)'=0
- Begin DoDot:2
- +9 SET IBI=0
- SET IBDG=$$FIND1^DIC(399,,,IBZZ(344.41,ZZ,.02,"E"),"B",)
- +10 ; EOB has been reapportioned at the site
- IF IBDG'=""
- FOR
- SET IBI=$ORDER(^IBM(361.1,"C",IBDG,IBI))
- if 'IBI
- QUIT
- if $GET(AA(IBI))'=1
- SET CNT=CNT+1
- SET @ARRAY@(CNT,IBI)=1
- End DoDot:2
- End DoDot:1
- +11 SET @ARRAY=CNT
- +12 QUIT
- +13 ;
- +14 ; IEN = IEN for File 399, CODE = Revenue Code, CPT = the procedure code for this line
- +15 ; Return the billed amount for this line
- BILLN(IEN,CODE,CPT) ; Get the line item information from the Bill
- +1 NEW RCOUT,II,RET
- +2 SET RET=0
- +3 KILL RCOUT
- DO FIND^DIC(399.042,","_IEN_",",".01;.02;.03;.04;.06","",CODE,"","","","","RCOUT")
- +4 SET II=""
- FOR
- SET II=$ORDER(RCOUT("DILIST","ID",II))
- if II=""
- QUIT
- IF RCOUT("DILIST","ID",II,.06)=CPT
- SET RET=RCOUT("DILIST","ID",II,.04)
- QUIT
- +5 QUIT RET
- +6 ;
- ADJU(TYPE,ARR1,END) ; Get the Deduction information from the line level
- +1 ; TYPE = "DEDUCT" or "COINS", pass array by reference, END - quit condition
- +2 NEW RCOUT,AA,BB,RET
- +3 SET RET=0
- +4 SET AA=END
- FOR
- SET AA=$ORDER(ARR1(361.1151,AA))
- if $EXTRACT(AA,1,$LENGTH(END))'=END
- QUIT
- if ARR1(361.1151,AA,.01,"I")="PR"
- Begin DoDot:1
- +5 SET BB=AA
- FOR
- SET BB=$ORDER(ARR1(361.11511,BB))
- if $EXTRACT(BB,1,$LENGTH(AA))'=AA
- QUIT
- Begin DoDot:2
- +6 ; Deductable
- IF TYPE="DEDUCT"
- if ARR1(361.11511,BB,.01,"E")=1
- SET RET=ARR1(361.11511,BB,.02,"E")
- +7 ; Co-Insurance
- IF TYPE="COINS"
- if ARR1(361.11511,BB,.01,"E")=2
- SET RET=ARR1(361.11511,BB,.02,"E")
- End DoDot:2
- if RET'=0
- QUIT
- End DoDot:1
- +8 QUIT RET
- +9 ;
- RESORT(ZAR,ZIDX) ; Resort the subscripts from GETS so items collate correctly while walking the array
- +1 ; Pass ZAR through indirection
- +2 ; Take the second subscript and reverse the pieces, put them in right order
- +3 if $GET(ZIDX)']""
- QUIT
- +4 NEW II,XX,YY,ZZ,Z1,ZN,A
- SET ZZ=""
- SET ZN=""
- +5 FOR
- SET ZZ=$ORDER(@ZAR@(ZIDX,ZZ))
- if ZZ=""
- QUIT
- Begin DoDot:1
- +6 SET ZN=""
- FOR II=1:1:($LENGTH(ZZ,",")-1)
- SET ZN=$PIECE(ZZ,",",II)_","_ZN
- +7 SET XX=""
- FOR
- SET XX=$ORDER(@ZAR@(ZIDX,ZZ,XX))
- if XX=""
- QUIT
- Begin DoDot:2
- +8 IF $DATA(@ZAR@(ZIDX,ZZ,XX,"E"))=1
- SET YY=@ZAR@(ZIDX,ZZ,XX,"E")
- KILL @ZAR@(ZIDX,ZZ,XX,"E")
- SET QQ(ZN,XX,"E")=YY
- +9 IF $DATA(@ZAR@(ZIDX,ZZ,XX,"I"))=1
- SET YY=@ZAR@(ZIDX,ZZ,XX,"I")
- KILL @ZAR@(ZIDX,ZZ,XX,"I")
- SET QQ(ZN,XX,"I")=YY
- End DoDot:2
- End DoDot:1
- +10 MERGE @ZAR@(ZIDX)=QQ
- +11 KILL QQ
- +12 QUIT
- +13 ;
- RECEIPT ; Go to Receipt profile
- +1 ; Build the ^TMP(RCDPDPLM,$J,"IDX",#,#)=# array if we have a receipt on this ERA
- +2 ; ERALST, IBIFN is passed in by IBJTEP and will be cleaned up there
- +3 NEW IBERA,IBEPB,IBRP,DIR,DTOUT,DUOUT,DZX,EPIEN,I,IX,INDEX,X,Y,IBARR,IBAR2,IBAR3,RCDEPTDA,RCRECTDA,RCDPFXIT
- +4 DO FULL^VALM1
- +5 SET VALMBCK="R"
- RC1 ;
- +1 SET IBRP(U)=", "
- +2 IF $LENGTH(ERALST,U)=1
- SET IBERA=ERALST
- GOTO RC2
- +3 SET DIR("A")="Enter ERA for receipt review: "
- SET DIR(0)="FA^1:10"
- +4 SET DIR("A",1)="Enter an ERA# from the following list for additional information."
- +5 SET DIR("A",2)="Available ERAs: "_$$REPLACE^XLFSTR(ERALST,.IBRP)
- +6 DO ^DIR
- KILL DIR
- +7 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
- GOTO RCQ
- +8 SET IBERA=Y
- IF (U_ERALST_U)'[(U_Y_U)
- WRITE !!,"ERA: "_Y_" not a valid selection. Please try again...",!
- SET X=""
- SET IBERA=""
- GOTO RC1
- +9 ;
- RC2 ;
- +1 IF $GET(IBERA)=""
- SET DIR("A",1)="No ERAs for this K-Bill exist."
- SET DIR(0)="EA"
- SET DIR("A")="Press ENTER to continue: "
- WRITE !
- DO ^DIR
- KILL DIR
- GOTO RCQ
- +2 ; Get zero node of ERA
- +3 SET ZN=$GET(^RCY(344.4,IBERA,0))
- +4 ; Get Reciept for this Bill
- +5 KILL IBEPB,^TMP("RCDPDPLM",$JOB)
- DO GETS^DIQ(344.4,IBERA_",","1*;","IE","IBEPB")
- +6 ; No Receipt then report and quit
- +7 IF $PIECE(ZN,U,8)=""
- IF $DATA(^RCY(344.4,IBERA,1,"RECEIPT"))=0
- SET DIR("A",1)="No receipts exist for this ERA."
- SET DIR(0)="EA"
- SET DIR("A")="Press ENTER to continue: "
- WRITE !
- DO ^DIR
- KILL DIR
- GOTO RCQ
- +8 ; Reciept, build temp global and call RECEIPTS
- +9 SET I=0
- SET IX=""
- FOR
- SET IX=$ORDER(IBEPB(344.41,IX))
- if IX=""
- QUIT
- IF $GET(IBEPB(344.41,IX,.02,"E"))=EPBILL
- Begin DoDot:1
- +10 ; Add Reciept to list if not already on this list
- +11 IF $GET(IBEPB(344.41,IX,.25,"I"))'=""
- if '$DATA(^TMP("RCDPDPLM",$JOB,"RCPT",IBEPB(344.41,IX,.25,"I")))
- SET I=I+1
- SET ^TMP("RCDPDPLM",$JOB,"IDX",I,I)=$GET(IBEPB(344.41,IX,.25,"I"))
- SET ^TMP("RCDPDPLM",$JOB,"RCPT",IBEPB(344.41,IX,.25,"I"))=""
- End DoDot:1
- +12 ; if no receipts, then set the single Receipt from the zero node.
- +13 IF '$DATA(^TMP("RCDPDPLM",$JOB,"IDX"))
- if $PIECE(ZN,U,8)'=""
- SET ^TMP("RCDPDPLM",$JOB,"IDX",1,1)=$PIECE(ZN,U,8)
- SET ^TMP("RCDPDPLM",$JOB,"RCPT",$PIECE(ZN,U,8))=""
- IF $PIECE(ZN,U,8)=""
- Begin DoDot:1
- +14 SET DIR("A",1)="Issue with ERA: "_IBERA_" and Bill No.: "_EPBILL
- SET DIR(0)="EA"
- SET DIR("A")="Press ENTER to continue: "
- WRITE !
- DO ^DIR
- KILL DIR
- End DoDot:1
- GOTO RCQ
- +15 ;
- +16 SET RCRECTDA=$$GETRCPT($NAME(^TMP("RCDPDPLM",$JOB,"IDX")))
- +17 ; no selection, "^" or read timeout
- IF RCRECTDA=-1
- GOTO RCQ
- +18 DO EN^VALM("RCDP RECEIPT PROFILE")
- +19 ;
- RCQ ;
- +1 ; If RCDPFXIT is set, exit option entirely was selected so quit back to the menu
- +2 IF $GET(RCDPFXIT)
- SET VALMBCK="Q"
- +3 KILL ^TMP("RCDPDPLM",$JOB)
- +4 QUIT
- +5 ;
- GETRCPT(ARRAY) ; If only one receipt return with the single receipt, otherwise user selects receipt
- +1 IF '$ORDER(@ARRAY@(1))
- QUIT $SELECT($GET(@ARRAY@(1,1))'="":$GET(@ARRAY@(1,1)),1:-1)
- +2 NEW ZX,ZY,ZZ,ZAR,DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT,QQ
- +3 SET ZZ=0
- SET QQ=""
- SET ZX=""
- FOR
- SET ZX=$ORDER(@ARRAY@(ZX))
- if ZX=""
- QUIT
- if QQ'=""
- SET QQ=QQ_";"
- SET ZZ=ZZ+1
- SET QQ=QQ_ZZ_":"_$PIECE($GET(^RCY(344,@ARRAY@(ZX,ZX),0)),U,1)
- SET ZAR(ZZ)=@ARRAY@(ZX,ZX)
- +4 SET DIR(0)="S^"_QQ
- +5 SET DIR("A")="Enter index number for Receipt"
- DO ^DIR
- KILL DIR
- +6 ; no selection/timeout quit
- IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
- QUIT -1
- +7 QUIT ZAR(Y)
- +8 ;
- GETRX(IBIEN,IBARRY) ;return pharmacy data to about EEOB items
- +1 ; input - IBIEN = ien to record in 361.1
- +2 ; IBARRY = Array name that will be used to store and return pharmacy data elements
- +3 ; output - IBARRY = holds pharmacy data
- +4 ; IA 6033 (controlled subscription) - read access of file 362.4. status is pending
- +5 ; ICR 1878 (supported) - usage of EN^PSOORDER
- +6 ;
- +7 NEW IB0,RXDATA,RXIEN,IBDFN,PRIEN,RXFILL
- +8 KILL IBARRY
- +9 if IBIEN=""
- QUIT
- +10 SET PRIEN=$PIECE(^IBM(361.1,IBIEN,0),U,1)
- if PRIEN=""
- QUIT
- +11 SET IBDFN=$PIECE(^PRCA(430,PRIEN,0),U,7)
- +12 SET IB0=+$ORDER(^IBA(362.4,"C",PRIEN,0))
- +13 if IB0=0
- QUIT
- +14 SET RXDATA=$GET(^IBA(362.4,IB0,0))
- +15 SET IBARRY("DOS")=$$FMTE^XLFDT($PIECE(RXDATA,U,3),"2Z")
- +16 ; rx fill#
- SET IBARRY("FILL")=+$PIECE(RXDATA,U,10)
- +17 ; RX ien ptr file 52
- SET RXIEN=+$PIECE(RXDATA,U,5)
- +18 DO EN^PSOORDER(IBDFN,RXIEN)
- +19 SET IBARRY("RX")=$PIECE(^TMP("PSOR",$JOB,RXIEN,0),U,5)
- +20 ; Release status from Rx on the first fill (no refills)
- IF IBARRY("FILL")=0
- SET IBARRY("RELEASED STATUS")=$SELECT($PIECE(^TMP("PSOR",$JOB,RXIEN,0),U,13)]"":"Released",1:"Not Released")
- +21 ; Release status from Rx refill #
- IF IBARRY("FILL")>0
- SET IBARRY("RELEASED STATUS")=$SELECT($PIECE(^TMP("PSOR",$JOB,RXIEN,"REF",IBARRY("FILL"),0),U,8)]"":"Released",1:"Not Released")
- +22 QUIT
- +23 ;
- EOBREM(RCEOB,LINE) ; EP from IBJTEP - Show EOB removal details if EOB removed
- +1 ; Input: RCEOB - Internal entry number from file 361.1
- +2 ; LINE - Line counter for ListMan storage
- +3 ; Output: To screen
- +4 ; Get last move/copy history record
- +5 NEW I,J,RCEOBH,RCJUST
- +6 SET RCEOBH=$ORDER(^IBM(361.1,RCEOB,101,"A"),-1)
- +7 ; Quit if EOB if no history found - should not occur since EOB is removed
- +8 IF 'RCEOBH
- DO SET^IBJTEP(.LINE,"**EOB Removed**")
- QUIT
- +9 ;
- +10 DO SET^IBJTEP(.LINE,"EOB Removed by : "_$$GET1^DIQ(361.1101,RCEOBH_","_RCEOB,.02,"E"))
- +11 DO SET^IBJTEP(.LINE,"Date/Time Removed : "_$$GET1^DIQ(361.1101,RCEOBH_","_RCEOB,.01,"E"))
- +12 SET RCJUST=$$GET1^DIQ(361.1101,RCEOBH_","_RCEOB,.03,"E")
- +13 ;
- IF $LENGTH(RCJUST>59)
- Begin DoDot:1
- +14 SET I=1
- +15 ;
- FOR J=1:1:$LENGTH(RCJUST," ")
- Begin DoDot:2
- +16 IF $LENGTH($GET(RCJUST(I))_$PIECE(RCJUST," ",J))>60
- SET I=I+1
- +17 SET RCJUST(I)=$GET(RCJUST(I))_" "_$PIECE(RCJUST," ",J)
- End DoDot:2
- End DoDot:1
- +18 IF '$TEST
- SET RCJUST(1)=RCJUST
- +19 DO SET^IBJTEP(.LINE,"Justification :"_$GET(RCJUST(1)))
- +20 FOR J=2:1:I
- DO SET^IBJTEP(.LINE," "_$GET(RCJUST(J)))
- +21 QUIT
- +22 ;
- +23 ; Make CARC or RARC description lines the right length for display - IB*2.0*633 Moved for routine size
- DLN(ZIN,ZARR,FLN,SLN) ;
- +1 ; ZIN - array to get lines of text
- +2 ; ZRARR - array for display passed by indirection
- +3 ; FLN - First line length; SLN - Second and subsequent line lengths
- +4 NEW ZI,ZX,ZL,ZXL,ZICT,ZCT,ZSP,ZLN
- +5 SET ZI=""
- SET ZCT=0
- SET ZICT=0
- +6 ; Get number of lines in array
- +7 FOR
- SET ZI=$ORDER(@ZIN@(ZI))
- if ZI=""
- QUIT
- SET ZICT=ZICT+1
- +8 ; If more than one line in array, process the line
- +9 if ZICT>1
- Begin DoDot:1
- +10 SET ZI=""
- SET ZL=""
- FOR
- SET ZI=$ORDER(@ZIN@(ZI))
- if ZI=""
- QUIT
- SET ZL=ZL_$SELECT($LENGTH(ZL)>1:" ",1:"")_@ZIN@(ZI)
- Begin DoDot:2
- +11 FOR
- if $LENGTH(ZL)<SLN
- QUIT
- SET ZCT=ZCT+1
- Begin DoDot:3
- +12 ; First line
- IF ZCT=1
- if $LENGTH(ZL)<FLN
- SET @ZARR@(ZCT)=ZL
- SET ZL=""
- if $LENGTH(ZL)>FLN
- Begin DoDot:4
- +13 SET ZXL=""
- FOR ZX=1:1
- if ($LENGTH(ZXL)+$LENGTH($PIECE(ZL," ",ZX)))>FLN
- QUIT
- SET ZXL=ZXL_$SELECT($LENGTH(ZXL)>0:" ",1:"")_$PIECE(ZL," ",ZX)
- +14 KILL ZSP
- SET @ZARR@(ZCT)=ZXL
- SET ZSP(ZXL)=""
- SET ZL=$$REPLACE^XLFSTR(ZL,.ZSP)
- SET ZL=$$TRIM^XLFSTR(ZL)
- End DoDot:4
- +15 if ZCT>1
- Begin DoDot:4
- +16 SET ZXL=""
- FOR ZX=1:1
- if ($LENGTH(ZXL)+$LENGTH($PIECE(ZL," ",ZX)))>SLN
- QUIT
- SET ZXL=ZXL_$SELECT($LENGTH(ZXL)>0:" ",1:"")_$PIECE(ZL," ",ZX)
- +17 KILL ZSP
- SET @ZARR@(ZCT)=ZXL
- SET ZSP(ZXL)=""
- SET ZL=$$REPLACE^XLFSTR(ZL,.ZSP)
- SET ZL=$$TRIM^XLFSTR(ZL)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- +18 IF ($LENGTH(ZL)>1)
- SET ZCT=ZCT+1
- SET @ZARR@(ZCT)=ZL
- SET ZL=""
- +19 SET @ZARR=ZCT
- End DoDot:1
- +20 ; One line in array break up if necessary
- +21 IF ZICT=1
- Begin DoDot:1
- +22 SET ZX=$ORDER(@ZIN@(""))
- +23 IF $LENGTH(@ZIN@(ZX))<FLN
- SET @ZARR@(1)=@ZIN@(ZX)
- SET @ZARR=1
- QUIT
- +24 ; Otherwise we are spanning two lines
- +25 SET ZL=""
- FOR ZI=1:1
- if ($LENGTH(ZL)+$LENGTH($PIECE(@ZIN@(ZX)," ",ZI)))>FLN
- QUIT
- SET ZL=ZL_$SELECT($LENGTH(ZL)>0:" ",1:"")_$PIECE(@ZIN@(ZX)," ",ZI)
- +26 SET @ZARR@(1)=ZL
- SET @ZARR@(2)=$PIECE(@ZIN@(ZX)," ",ZI,9999)
- +27 SET @ZARR=2
- End DoDot:1
- +28 QUIT
