RCDPEWL5 ;ALB/TMK/PJH - ELECTRONIC EOB WORKLIST ACTIONS ; 7/30/10 6:52pm
;;4.5;Accounts Receivable;**173,208,269**;Mar 20, 1995;Build 113
;;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
INIT ; Build receipt preview
N X,Z,Z1,Z10,Z0,Z2,RCZ
K ^TMP("RCDPE_EOB_PREVIEW",$J)
S VALMCNT=0,VALMBG=1
S Z=0 F S Z=$O(^RCY(344.49,RCSCR,1,Z)) Q:'Z S Z0=$G(^(Z,0)) D
. I $P(Z0,U)\1=+Z0 S Z2=$P(Z0,U,2)
. I $P($P(Z0,U),".",2) D
.. S:$P(Z0,U,2)="" $P(Z0,U,2)=Z2
.. S RCZ=$S(+$P(Z0,U,6)=0:0,+$P(Z0,U,6)<0:-1,$P(Z0,U,7):1,1:2)
.. S RCZ(RCZ,Z)=Z0
.. S Z1=0 F S Z1=$O(^RCY(344.49,RCSCR,1,Z,1,Z1)) Q:'Z1 S Z10=$G(^(Z1,0)) D
... I $P(Z10,U,5)=1 S RCZ(RCZ,Z,"ADJ",Z1)="Dec adj $"_$J(0-$P(Z10,U,3),"",2)_" pending - ",RCZ(RCZ,Z,"ADJ",Z1,1)=$J("",4)_$P(Z10,U,9)
F RCZ=1,2,0,-1 D
. Q:'$D(RCZ(RCZ))
. I RCZ=1 D SET("PAYMENTS (LINES FOR RECEIPT):")
. I RCZ=0,VALMCNT>0 D SET(" ") D SET("ZERO DOLLAR PAYMENTS:")
. I RCZ=-1,VALMCNT>0 D SET(" ") D SET("LINES WITH NEGATIVE BALANCES STILL NEEDING TO BE DISTRIBUTED:")
. S Z=0 F S Z=$O(RCZ(RCZ,Z)) Q:'Z S Z0=RCZ(RCZ,Z) D
.. S X=""
.. S X=$$SETFLD^VALM1($P(Z0,U),X,"LINE #")
.. S X=$$SETFLD^VALM1($S($P(Z0,U,7):$$BN1^PRCAFN($P(Z0,U,7)),1:$S(RCZ=0:"",1:"[SUSPENSE]")_$S($P(Z0,U,2)["**ADJ"&'$P($P(Z0,U,2),"ADJ",2):"TOTALS MISMATCH ADJ",1:$P(Z0,U,2))),X,"ACCOUNT")
.. S X=$$SETFLD^VALM1($J(+$P(Z0,U,6),"",2),X,"AMOUNT")
.. D SET(X)
.. S Z1=0 F S Z1=$O(RCZ(RCZ,Z,"ADJ",Z1)) Q:'Z1 D SET($J("",12)_$G(RCZ(RCZ,Z,"ADJ",Z1))) S Z2=0 F S Z2=$O(RCZ(RCZ,Z,"ADJ",Z1,Z2)) Q:'Z2 D SET($J("",12)_$G(RCZ(RCZ,Z,"ADJ",Z1,Z2)))
Q
;
SET(X) ;
S VALMCNT=VALMCNT+1
S ^TMP("RCDPE_EOB_PREVIEW",$J,VALMCNT,0)=X
Q
;
HDR ;
D HDR^RCDPEWL
Q
;
FNL ;
K ^TMP("RCDPE_EOB_PREVIEW",$J)
Q
;
RCOMM ; Allow entry of receipt comment to be moved to line on receipt
N RCEDIT
D FULL^VALM1
;
I $G(RCSCR("NOEDIT"))=2 D NOTAV^RCDPEWL2 G RCOMMQ
;
D SEL^RCDPEWL2(.RCEDIT)
G:'RCEDIT RCOMMQ
;
RCOMMQ S VALMBCK="R"
Q
;
SUSPERA ; Option entrypoint to select an ERA to be posted to suspense
N DIC,X,Y,RCERA,RCSCR,DTOUT,DUOUT,DIR
S DIC(0)="AEMQ",DIC="^RCY(344.4,",DIC("S")="I '$P(^(0),U,8),'$G(^(20))"
D ^DIC K DIC
I Y'>0 Q
S RCERA=+Y
S DIR(0)="YA",DIR("B")="YES",DIR("A")="DO YOU WANT TO PRINT/VIEW THE ERA FIRST?: " W ! D ^DIR K DIR
Q:$D(DUOUT)!$D(DTOUT)
I Y=1 S RCSCR=RCERA D PRERA^RCDPEWL0
D SUSP(RCERA,0)
Q
;
SUSP(RCERA,LM) ; Function to send receipt to suspense for ERA
; RCERA = ien of entry in file 344.4
; LM = flag to indicate it was called from list manager protocol
; = 1 if true, 0 if false
N DIR,X,Y,RC0,RCCOM,RCER,RCPAYTY,RECTDA,RCTRANDA,DIE,DA,DR,Z,DTOUT,DUOUT,RC5
S RC0=$G(^RCY(344.4,RCERA,0)),RC5=$G(^RCY(344.4,RCERA,5))
I $G(LM) D FULL^VALM1
I $$HACERA^RCDPEU(RCERA) D G SUSPQ
. S DIR(0)="EA",DIR("A")="THIS IS NOT A VALID ACTION FOR AN ERA FROM HAC" W ! D ^DIR K DIR
S DIR(0)="YA",DIR("B")="NO"
I $P(RC0,U,5) D
. S DIR("A",1)="THIS WILL CREATE A RECEIPT THAT WILL MOVE THE FUNDS ($"_$J($P(RC0,U,5),"",2)_")",DIR("A",2)="FOR THIS ENTIRE ERA TO YOUR SUSPENSE ACCOUNT",Z=3
E D
. S DIR("A",1)="THIS WILL CREATE AND POST A RECEIPT FOR $0.00 FOR THIS ERA",Z=2
S DIR("A",Z+1)=" ",DIR("A",Z+2)="***ALL POSTINGS TO A/R FOR ANY CLAIMS IN THIS ERA MUST BE DONE MANUALLY***",DIR("A",Z+3)=" "
S DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE?: "
W ! D ^DIR K DIR
I Y'=1 D NOACT G SUSPQ
S DIR("A",1)="ENTER A 1-60 CHARACTER COMMENT TO BE PLACED ON THE RECEIPT: ",DIR("A")=">: ",DIR(0)="FA^1:60",DIR("B")="REF ERA #:"_RCERA_" FROM "_$E($P(RC0,U,6),1,20) W ! D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT) D NOACT G SUSPQ
S RCCOM=Y
S RCPAYTY=$S($P(RC5,U,2)="":14,1:4)
S RECTDA=$$BLDRCPT^RCDPUREC(DT,"",+$O(^RC(341.1,"AC",+RCPAYTY,0)))
I 'RECTDA D G SUSPQ
. S DIR(0)="EA",DIR("A",1)="A PROBLEM WAS ENCOUNTERED ADDING THE RECEIPT",DIR("A")="NO ACTION TAKEN - RETURN TO CONTINUE: " W ! D ^DIR K DIR
;
S RCTRANDA=$$ADDTRAN^RCDPURET(RECTDA)
S DR=".04////"_(+$P(RC0,U,5))_$S($P(RC5,U,2)'="":";.13////"_$P(RC5,U,2),1:"")_$S(RCCOM'="":";1.02////"_RCCOM,1:"")
S DA(1)=RECTDA,DA=RCTRANDA,DIE="^RCY(344,"_DA(1)_",1,"
D ^DIE
;
I $D(^RCY(344.49,RCERA,0)) S DIE="^RCY(344.49,",DA=RCERA,DR=".02////"_RECTDA D ^DIE
S DIE="^RCY(344.4,",DA=RCERA,DR=".08////"_RECTDA_";20.01///^S X=""NOW"";20.02////"_DUZ D ^DIE
S Z=+$O(^RCY(344.31,"AERA",RCERA,0))
S DIE="^RCY(344,",DA=RECTDA,DR=".18////"_RCERA_$S(Z:";.17////"_Z,1:"") D ^DIE
;
D PROCESS^RCDPURE1(RECTDA,1)
I '$P(RC0,U,5) S DIE="^RCY(344.4,",DA=RCERA,DR=".09////3;.14////1" D ^DIE
S DIR(0)="E" W ! D ^DIR K DIR
;
SUSPQ I $G(LM) S VALMBCK="R"
Q
;
REVIEW ; Enter review information on worklist and turn review display on/off
; Assumes RCSCR = ien of the entry in file 344.49
;
N Z,RC,RCDA,RCZ,DIC,DA,DIE,DR,X,Y,DIR,REVCHG,RCUSPREF,RCLSTREV,RCREV
D FULL^VALM1
;
S REVCHG=""
S DIR(0)="YA",RC=+$P($G(^TMP($J,"RC_SORTPARM")),U,2)
S DIR("A",1)="REVIEW DATA DISPLAY IS CURRENTLY TURNED "_$P("OFF^ON",U,RC+1),DIR("A")="DO YOU WANT TO TURN IT "_$P("ON^OFF",U,RC+1)_"?: ",DIR("B")=$S('RC:"YES",1:"NO") W ! D ^DIR K DIR
I Y=1 S $P(^TMP($J,"RC_SORTPARM"),U,2)=((RC+1)#2),REVCHG=1
S RCUSPREF=+$O(^RCY(344.49,RCSCR,2,"B",DUZ,0))
;
I 'RCUSPREF D ; Add the user pref record
. S RCUSPREF=+$$ADDUSER(RCSCR,DUZ)
S RCLSTREV=+$P($G(^RCY(344.49,RCSCR,2,RCUSPREF,0)),U,2)
S DA(1)=RCSCR,DA=RCUSPREF
I DA,RCLSTREV'=$P($G(^TMP($J,"RC_SORTPARM")),U,2) D ; Update user pref
. S DIE="^RCY(344.49,"_DA(1)_",2,",DR=".02////"_+$P($G(^TMP($J,"RC_SORTPARM")),U,2) D ^DIE
W !
I '$P(^TMP($J,"RC_SORTPARM"),U,2) G REVIEWQ
;
D SEL^RCDPEWL(.RCDA)
S RCZ=+$O(RCDA(0)),RCZ=+$G(RCDA(RCZ)) G:'RCZ REVIEWQ
;
S RCREV=0
I '$O(^RCY(344.49,RCSCR,1,"AC",DUZ,RCZ,0)) D
. S RCREV=$$NEWREV(RCSCR,RCZ,DUZ)
E D
. N DIR,X,Y
. S DIR("A")="(A)DD or (E)DIT A REVIEW COMMENT?: ",DIR("B")="ADD",DIR(0)="SA^A:ADD;E:EDIT" W ! D ^DIR K DIR
. I $D(DUOUT)!$D(DTOUT) Q
. ;
. I Y="E" D Q ; Edit a review entry entered by same user
.. N DA,DR,DIE,X,Y
.. S DA(1)=RCSCR,DA=RCZ,DIC="^RCY(344.49,"_DA(1)_",1,"_DA_",4,",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,2)=DUZ" D ^DIC
.. S RCREV=$S(Y>0:+Y,1:0)
.. I RCREV S DA(2)=RCSCR,DA(1)=RCZ,DA=RCREV,DIE="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",4,",DR=".03;.04////^S X=$$NOW^XLFDT()" D ^DIE
. ;
. S RCREV=$$NEWREV(RCSCR,RCZ,DUZ)
;
I RCREV S DIE("NO^")="",DA(1)=RCSCR,DA=RCZ,DIE="^RCY(344.49,"_DA(1)_",1,",DR=".11R;I X=0 S Y=""@10"";.12////^S X=DUZ;S Y=""@20"";@10;.12///@;@20" D ^DIE K DIE
D BLD^RCDPEWL1($G(^TMP($J,"RC_SORTPARM")))
S REVCHG=""
;
REVIEWQ I $G(REVCHG) D BLD^RCDPEWL1($G(^TMP($J,"RC_SORTPARM")))
S VALMBCK="R"
Q
;
NEWREV(RCSCR,RCZ,RCDUZ) ; Enter a new review comment
; RCSCR = ien of entry in file 344.49
; RCZ = ien of the EEOB (seq #)
; RCDUZ =DUZ of user entering the comment
; Function returns 0 if no new comment, ien of comment if added
N DA,X,Y,DIC,DIK,DLAYGO,DO,DD,RCREV,RCNOW
S RCNOW=$$NOW^XLFDT() W !!,"REVIEW DATE/TIME: "_$$FMTE^XLFDT(RCNOW,"2")
S DA(2)=RCSCR,DA(1)=RCZ,X=RCNOW,DIC("DR")=".02////"_RCDUZ_";.03",DLAYGO=344.492,DIC(0)="L"
S DIC="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",4,"
K DO,DD
D FILE^DICN K DO,DD,DIC,DLAYGO
S RCREV=+Y
I RCREV'>0 S RCREV=0 G NEWREVQ
I '$O(^RCY(344.49,DA(2),1,DA(1),4,RCREV,0)) S DIK="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",4,",DA=RCREV D ^DIK S RCREV=0 ; No comment - delete entry
;
NEWREVQ Q RCREV
;
NOACT ;
N DIR,X,Y
S DIR(0)="EA",DIR("A")="NO ACTION TAKEN - RETURN TO CONTINUE: " W ! D ^DIR K DIR
Q
;
ADDUSER(RCSCR,RCDUZ) ; Add user record to user preferences multiple in file 344.49 and initialize all preferences
; RCSCR = ien of entry in file 344.49
; RCDUZ = the ien of the user
N DIC,DA,X,Y,DLAYGO,DO,DD
S Y=+$O(^RCY(344.49,RCSCR,2,"B",RCDUZ,0))
I Y G ADDUQ
S DLAYGO=344.492,DA(1)=RCSCR,DIC(0)="L",X=RCDUZ,DIC="^RCY(344.49,"_DA(1)_",2,",DIC("DR")=".02////0;.03////N"
D FILE^DICN K DIC,DLAYGO
ADDUQ Q $S(Y>0:Y,1:0)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEWL5 8029 printed Sep 23, 2025@19:21:51 Page 2
RCDPEWL5 ;ALB/TMK/PJH - ELECTRONIC EOB WORKLIST ACTIONS ; 7/30/10 6:52pm
+1 ;;4.5;Accounts Receivable;**173,208,269**;Mar 20, 1995;Build 113
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
INIT ; Build receipt preview
+1 NEW X,Z,Z1,Z10,Z0,Z2,RCZ
+2 KILL ^TMP("RCDPE_EOB_PREVIEW",$JOB)
+3 SET VALMCNT=0
SET VALMBG=1
+4 SET Z=0
FOR
SET Z=$ORDER(^RCY(344.49,RCSCR,1,Z))
if 'Z
QUIT
SET Z0=$GET(^(Z,0))
Begin DoDot:1
+5 IF $PIECE(Z0,U)\1=+Z0
SET Z2=$PIECE(Z0,U,2)
+6 IF $PIECE($PIECE(Z0,U),".",2)
Begin DoDot:2
+7 if $PIECE(Z0,U,2)=""
SET $PIECE(Z0,U,2)=Z2
+8 SET RCZ=$SELECT(+$PIECE(Z0,U,6)=0:0,+$PIECE(Z0,U,6)<0:-1,$PIECE(Z0,U,7):1,1:2)
+9 SET RCZ(RCZ,Z)=Z0
+10 SET Z1=0
FOR
SET Z1=$ORDER(^RCY(344.49,RCSCR,1,Z,1,Z1))
if 'Z1
QUIT
SET Z10=$GET(^(Z1,0))
Begin DoDot:3
+11 IF $PIECE(Z10,U,5)=1
SET RCZ(RCZ,Z,"ADJ",Z1)="Dec adj $"_$JUSTIFY(0-$PIECE(Z10,U,3),"",2)_" pending - "
SET RCZ(RCZ,Z,"ADJ",Z1,1)=$JUSTIFY("",4)_$PIECE(Z10,U,9)
End DoDot:3
End DoDot:2
End DoDot:1
+12 FOR RCZ=1,2,0,-1
Begin DoDot:1
+13 if '$DATA(RCZ(RCZ))
QUIT
+14 IF RCZ=1
DO SET("PAYMENTS (LINES FOR RECEIPT):")
+15 IF RCZ=0
IF VALMCNT>0
DO SET(" ")
DO SET("ZERO DOLLAR PAYMENTS:")
+16 IF RCZ=-1
IF VALMCNT>0
DO SET(" ")
DO SET("LINES WITH NEGATIVE BALANCES STILL NEEDING TO BE DISTRIBUTED:")
+17 SET Z=0
FOR
SET Z=$ORDER(RCZ(RCZ,Z))
if 'Z
QUIT
SET Z0=RCZ(RCZ,Z)
Begin DoDot:2
+18 SET X=""
+19 SET X=$$SETFLD^VALM1($PIECE(Z0,U),X,"LINE #")
+20 SET X=$$SETFLD^VALM1($SELECT($PIECE(Z0,U,7):$$BN1^PRCAFN($PIECE(Z0,U,7)),1:$SELECT(RCZ=0:"",1:"[SUSPENSE]")_$SELECT($PIECE(Z0,U,2)["**ADJ"&'$PIECE($PIECE(Z0,U,2),"ADJ",2):"TOTALS MISMATCH ADJ",1:$PIECE(Z0,U,2))),X,"ACCOUNT")
+21 SET X=$$SETFLD^VALM1($JUSTIFY(+$PIECE(Z0,U,6),"",2),X,"AMOUNT")
+22 DO SET(X)
+23 SET Z1=0
FOR
SET Z1=$ORDER(RCZ(RCZ,Z,"ADJ",Z1))
if 'Z1
QUIT
DO SET($JUSTIFY("",12)_$GET(RCZ(RCZ,Z,"ADJ",Z1)))
SET Z2=0
FOR
SET Z2=$ORDER(RCZ(RCZ,Z,"ADJ",Z1,Z2))
if 'Z2
QUIT
DO SET($JUSTIFY("",12)_$GET(RCZ(RCZ,Z,"ADJ",Z1,Z2)))
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;
SET(X) ;
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("RCDPE_EOB_PREVIEW",$JOB,VALMCNT,0)=X
+3 QUIT
+4 ;
HDR ;
+1 DO HDR^RCDPEWL
+2 QUIT
+3 ;
FNL ;
+1 KILL ^TMP("RCDPE_EOB_PREVIEW",$JOB)
+2 QUIT
+3 ;
RCOMM ; Allow entry of receipt comment to be moved to line on receipt
+1 NEW RCEDIT
+2 DO FULL^VALM1
+3 ;
+4 IF $GET(RCSCR("NOEDIT"))=2
DO NOTAV^RCDPEWL2
GOTO RCOMMQ
+5 ;
+6 DO SEL^RCDPEWL2(.RCEDIT)
+7 if 'RCEDIT
GOTO RCOMMQ
+8 ;
RCOMMQ SET VALMBCK="R"
+1 QUIT
+2 ;
SUSPERA ; Option entrypoint to select an ERA to be posted to suspense
+1 NEW DIC,X,Y,RCERA,RCSCR,DTOUT,DUOUT,DIR
+2 SET DIC(0)="AEMQ"
SET DIC="^RCY(344.4,"
SET DIC("S")="I '$P(^(0),U,8),'$G(^(20))"
+3 DO ^DIC
KILL DIC
+4 IF Y'>0
QUIT
+5 SET RCERA=+Y
+6 SET DIR(0)="YA"
SET DIR("B")="YES"
SET DIR("A")="DO YOU WANT TO PRINT/VIEW THE ERA FIRST?: "
WRITE !
DO ^DIR
KILL DIR
+7 if $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+8 IF Y=1
SET RCSCR=RCERA
DO PRERA^RCDPEWL0
+9 DO SUSP(RCERA,0)
+10 QUIT
+11 ;
SUSP(RCERA,LM) ; Function to send receipt to suspense for ERA
+1 ; RCERA = ien of entry in file 344.4
+2 ; LM = flag to indicate it was called from list manager protocol
+3 ; = 1 if true, 0 if false
+4 NEW DIR,X,Y,RC0,RCCOM,RCER,RCPAYTY,RECTDA,RCTRANDA,DIE,DA,DR,Z,DTOUT,DUOUT,RC5
+5 SET RC0=$GET(^RCY(344.4,RCERA,0))
SET RC5=$GET(^RCY(344.4,RCERA,5))
+6 IF $GET(LM)
DO FULL^VALM1
+7 IF $$HACERA^RCDPEU(RCERA)
Begin DoDot:1
+8 SET DIR(0)="EA"
SET DIR("A")="THIS IS NOT A VALID ACTION FOR AN ERA FROM HAC"
WRITE !
DO ^DIR
KILL DIR
End DoDot:1
GOTO SUSPQ
+9 SET DIR(0)="YA"
SET DIR("B")="NO"
+10 IF $PIECE(RC0,U,5)
Begin DoDot:1
+11 SET DIR("A",1)="THIS WILL CREATE A RECEIPT THAT WILL MOVE THE FUNDS ($"_$JUSTIFY($PIECE(RC0,U,5),"",2)_")"
SET DIR("A",2)="FOR THIS ENTIRE ERA TO YOUR SUSPENSE ACCOUNT"
SET Z=3
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 SET DIR("A",1)="THIS WILL CREATE AND POST A RECEIPT FOR $0.00 FOR THIS ERA"
SET Z=2
End DoDot:1
+14 SET DIR("A",Z+1)=" "
SET DIR("A",Z+2)="***ALL POSTINGS TO A/R FOR ANY CLAIMS IN THIS ERA MUST BE DONE MANUALLY***"
SET DIR("A",Z+3)=" "
+15 SET DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE?: "
+16 WRITE !
DO ^DIR
KILL DIR
+17 IF Y'=1
DO NOACT
GOTO SUSPQ
+18 SET DIR("A",1)="ENTER A 1-60 CHARACTER COMMENT TO BE PLACED ON THE RECEIPT: "
SET DIR("A")=">: "
SET DIR(0)="FA^1:60"
SET DIR("B")="REF ERA #:"_RCERA_" FROM "_$EXTRACT($PIECE(RC0,U,6),1,20)
WRITE !
DO ^DIR
KILL DIR
+19 IF $DATA(DTOUT)!$DATA(DUOUT)
DO NOACT
GOTO SUSPQ
+20 SET RCCOM=Y
+21 SET RCPAYTY=$SELECT($PIECE(RC5,U,2)="":14,1:4)
+22 SET RECTDA=$$BLDRCPT^RCDPUREC(DT,"",+$ORDER(^RC(341.1,"AC",+RCPAYTY,0)))
+23 IF 'RECTDA
Begin DoDot:1
+24 SET DIR(0)="EA"
SET DIR("A",1)="A PROBLEM WAS ENCOUNTERED ADDING THE RECEIPT"
SET DIR("A")="NO ACTION TAKEN - RETURN TO CONTINUE: "
WRITE !
DO ^DIR
KILL DIR
End DoDot:1
GOTO SUSPQ
+25 ;
+26 SET RCTRANDA=$$ADDTRAN^RCDPURET(RECTDA)
+27 SET DR=".04////"_(+$PIECE(RC0,U,5))_$SELECT($PIECE(RC5,U,2)'="":";.13////"_$PIECE(RC5,U,2),1:"")_$SELECT(RCCOM'="":";1.02////"_RCCOM,1:"")
+28 SET DA(1)=RECTDA
SET DA=RCTRANDA
SET DIE="^RCY(344,"_DA(1)_",1,"
+29 DO ^DIE
+30 ;
+31 IF $DATA(^RCY(344.49,RCERA,0))
SET DIE="^RCY(344.49,"
SET DA=RCERA
SET DR=".02////"_RECTDA
DO ^DIE
+32 SET DIE="^RCY(344.4,"
SET DA=RCERA
SET DR=".08////"_RECTDA_";20.01///^S X=""NOW"";20.02////"_DUZ
DO ^DIE
+33 SET Z=+$ORDER(^RCY(344.31,"AERA",RCERA,0))
+34 SET DIE="^RCY(344,"
SET DA=RECTDA
SET DR=".18////"_RCERA_$SELECT(Z:";.17////"_Z,1:"")
DO ^DIE
+35 ;
+36 DO PROCESS^RCDPURE1(RECTDA,1)
+37 IF '$PIECE(RC0,U,5)
SET DIE="^RCY(344.4,"
SET DA=RCERA
SET DR=".09////3;.14////1"
DO ^DIE
+38 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
+39 ;
SUSPQ IF $GET(LM)
SET VALMBCK="R"
+1 QUIT
+2 ;
REVIEW ; Enter review information on worklist and turn review display on/off
+1 ; Assumes RCSCR = ien of the entry in file 344.49
+2 ;
+3 NEW Z,RC,RCDA,RCZ,DIC,DA,DIE,DR,X,Y,DIR,REVCHG,RCUSPREF,RCLSTREV,RCREV
+4 DO FULL^VALM1
+5 ;
+6 SET REVCHG=""
+7 SET DIR(0)="YA"
SET RC=+$PIECE($GET(^TMP($JOB,"RC_SORTPARM")),U,2)
+8 SET DIR("A",1)="REVIEW DATA DISPLAY IS CURRENTLY TURNED "_$PIECE("OFF^ON",U,RC+1)
SET DIR("A")="DO YOU WANT TO TURN IT "_$PIECE("ON^OFF",U,RC+1)_"?: "
SET DIR("B")=$SELECT('RC:"YES",1:"NO")
WRITE !
DO ^DIR
KILL DIR
+9 IF Y=1
SET $PIECE(^TMP($JOB,"RC_SORTPARM"),U,2)=((RC+1)#2)
SET REVCHG=1
+10 SET RCUSPREF=+$ORDER(^RCY(344.49,RCSCR,2,"B",DUZ,0))
+11 ;
+12 ; Add the user pref record
IF 'RCUSPREF
Begin DoDot:1
+13 SET RCUSPREF=+$$ADDUSER(RCSCR,DUZ)
End DoDot:1
+14 SET RCLSTREV=+$PIECE($GET(^RCY(344.49,RCSCR,2,RCUSPREF,0)),U,2)
+15 SET DA(1)=RCSCR
SET DA=RCUSPREF
+16 ; Update user pref
IF DA
IF RCLSTREV'=$PIECE($GET(^TMP($JOB,"RC_SORTPARM")),U,2)
Begin DoDot:1
+17 SET DIE="^RCY(344.49,"_DA(1)_",2,"
SET DR=".02////"_+$PIECE($GET(^TMP($JOB,"RC_SORTPARM")),U,2)
DO ^DIE
End DoDot:1
+18 WRITE !
+19 IF '$PIECE(^TMP($JOB,"RC_SORTPARM"),U,2)
GOTO REVIEWQ
+20 ;
+21 DO SEL^RCDPEWL(.RCDA)
+22 SET RCZ=+$ORDER(RCDA(0))
SET RCZ=+$GET(RCDA(RCZ))
if 'RCZ
GOTO REVIEWQ
+23 ;
+24 SET RCREV=0
+25 IF '$ORDER(^RCY(344.49,RCSCR,1,"AC",DUZ,RCZ,0))
Begin DoDot:1
+26 SET RCREV=$$NEWREV(RCSCR,RCZ,DUZ)
End DoDot:1
+27 IF '$TEST
Begin DoDot:1
+28 NEW DIR,X,Y
+29 SET DIR("A")="(A)DD or (E)DIT A REVIEW COMMENT?: "
SET DIR("B")="ADD"
SET DIR(0)="SA^A:ADD;E:EDIT"
WRITE !
DO ^DIR
KILL DIR
+30 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+31 ;
+32 ; Edit a review entry entered by same user
IF Y="E"
Begin DoDot:2
+33 NEW DA,DR,DIE,X,Y
+34 SET DA(1)=RCSCR
SET DA=RCZ
SET DIC="^RCY(344.49,"_DA(1)_",1,"_DA_",4,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $P(^(0),U,2)=DUZ"
DO ^DIC
+35 SET RCREV=$SELECT(Y>0:+Y,1:0)
+36 IF RCREV
SET DA(2)=RCSCR
SET DA(1)=RCZ
SET DA=RCREV
SET DIE="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",4,"
SET DR=".03;.04////^S X=$$NOW^XLFDT()"
DO ^DIE
End DoDot:2
QUIT
+37 ;
+38 SET RCREV=$$NEWREV(RCSCR,RCZ,DUZ)
End DoDot:1
+39 ;
+40 IF RCREV
SET DIE("NO^")=""
SET DA(1)=RCSCR
SET DA=RCZ
SET DIE="^RCY(344.49,"_DA(1)_",1,"
SET DR=".11R;I X=0 S Y=""@10"";.12////^S X=DUZ;S Y=""@20"";@10;.12///@;@20"
DO ^DIE
KILL DIE
+41 DO BLD^RCDPEWL1($GET(^TMP($JOB,"RC_SORTPARM")))
+42 SET REVCHG=""
+43 ;
REVIEWQ IF $GET(REVCHG)
DO BLD^RCDPEWL1($GET(^TMP($JOB,"RC_SORTPARM")))
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
NEWREV(RCSCR,RCZ,RCDUZ) ; Enter a new review comment
+1 ; RCSCR = ien of entry in file 344.49
+2 ; RCZ = ien of the EEOB (seq #)
+3 ; RCDUZ =DUZ of user entering the comment
+4 ; Function returns 0 if no new comment, ien of comment if added
+5 NEW DA,X,Y,DIC,DIK,DLAYGO,DO,DD,RCREV,RCNOW
+6 SET RCNOW=$$NOW^XLFDT()
WRITE !!,"REVIEW DATE/TIME: "_$$FMTE^XLFDT(RCNOW,"2")
+7 SET DA(2)=RCSCR
SET DA(1)=RCZ
SET X=RCNOW
SET DIC("DR")=".02////"_RCDUZ_";.03"
SET DLAYGO=344.492
SET DIC(0)="L"
+8 SET DIC="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",4,"
+9 KILL DO,DD
+10 DO FILE^DICN
KILL DO,DD,DIC,DLAYGO
+11 SET RCREV=+Y
+12 IF RCREV'>0
SET RCREV=0
GOTO NEWREVQ
+13 ; No comment - delete entry
IF '$ORDER(^RCY(344.49,DA(2),1,DA(1),4,RCREV,0))
SET DIK="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",4,"
SET DA=RCREV
DO ^DIK
SET RCREV=0
+14 ;
NEWREVQ QUIT RCREV
+1 ;
NOACT ;
+1 NEW DIR,X,Y
+2 SET DIR(0)="EA"
SET DIR("A")="NO ACTION TAKEN - RETURN TO CONTINUE: "
WRITE !
DO ^DIR
KILL DIR
+3 QUIT
+4 ;
ADDUSER(RCSCR,RCDUZ) ; Add user record to user preferences multiple in file 344.49 and initialize all preferences
+1 ; RCSCR = ien of entry in file 344.49
+2 ; RCDUZ = the ien of the user
+3 NEW DIC,DA,X,Y,DLAYGO,DO,DD
+4 SET Y=+$ORDER(^RCY(344.49,RCSCR,2,"B",RCDUZ,0))
+5 IF Y
GOTO ADDUQ
+6 SET DLAYGO=344.492
SET DA(1)=RCSCR
SET DIC(0)="L"
SET X=RCDUZ
SET DIC="^RCY(344.49,"_DA(1)_",2,"
SET DIC("DR")=".02////0;.03////N"
+7 DO FILE^DICN
KILL DIC,DLAYGO
ADDUQ QUIT $SELECT(Y>0:Y,1:0)
+1 ;
