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 09, 2024@21:37:50 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
