- RCDPEWL4 ;ALB/TMK/PJH - ELECTRONIC EOB WORKLIST ACTIONS ;Jun 06, 2014@19:11:19
- ;;4.5;Accounts Receivable;**173,208,269,298,303,318,326,349,367**;Mar 20, 1995;Build 11
- ;;Per VA Directive 6402, this routine should not be modified.
- ; RCSCR variable must be defined for this routine
- Q
- ;
- DISTADJ(RCFR,RCTO,RCAMT,RCCOM) ; Action that distributes an adjustment amount
- ; against another line item's payment
- ; Assumes RCSCR = ien of the entry in file 344.49
- ; RCFR = ien of entry in 344.491 that has a negative net
- ; RCTO = ien of entry in 344.491 that will be decremented
- ; RCAMT = the amount being adjusted (positive #)
- ; RCCOM = the comment to place on the decrease adjustment
- ;
- N RCFRX,RCREF,RCFR0,RCFR1,RCFR10,RCTO0,RCTO1,RCTO10,RCY
- N DA,DD,DIK,DR,DIC,DIE,DIK,DIR,DLAYGO,DO,NONVA,X,Y ; PRCA*4.5*326
- I $G(^TMP("RCBATCH_SELECTED",$J)) D NOBATCH^RCDPEWL Q
- S RCFR0=$G(^RCY(344.49,RCSCR,1,RCFR,0)),RCTO0=$G(^RCY(344.49,RCSCR,1,RCTO,0)),RCFRX=+$O(^RCY(344.49,RCSCR,1,"B",RCFR0\1,0)),RCFRX=$G(^RCY(344.49,RCSCR,1,RCFRX,0))
- S RCREF=$P($P(RCFRX,U,2),"**ADJ",2),RCREF=$S(RCREF="":"",RCREF=0:$P(RCFRX,U,9),1:$P($G(^RCY(344.4,RCSCR,2,+RCREF,0)),U))
- S RCFR1=+$O(^RCY(344.49,RCSCR,1,"B",RCFR0\1,0)),RCTO1=+$O(^RCY(344.49,RCSCR,1,"B",RCTO0\1,0))
- S RCFR10=$G(^RCY(344.49,RCSCR,1,RCFR1,0)),RCTO10=$G(^RCY(344.49,RCSCR,1,RCTO1,0))
- S RCFR0=$G(^RCY(344.49,RCSCR,1,RCFR,0)),RCTO0=$G(^RCY(344.49,RCSCR,1,RCTO,0))
- S DA(2)=RCSCR,DA(1)=RCFR
- S DIC("DR")=".02////1;.03////"_RCAMT_";.04////"_$S($P(RCTO0,U,2)'="":$P(RCTO0,U,2),RCREF'="":RCREF,1:"UNKNOWN")
- S DIC("DR")=DIC("DR")_";.05////0;.06////0;.09////RETRACTED FUNDS DEDUCTED FROM OTHER PAYMENT ON THIS ERA",DIC="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",1,"
- S DLAYGO=344.4911,DIC(0)="L",X=+$O(^RCY(344.49,RCSCR,1,RCFR,1,"B",""),-1)+1
- D FILE^DICN K DIC,DD,DO,DLAYGO
- S RCY=+Y
- I RCY'>0 D Q
- . S DIR(0)="EA",DIR("A",1)="PROBLEM ADDING ADJUSTMENT - NO DISTRIBUTION PERFORMED",DIR("A")="PRESS RETURN TO CONTINUE " D ^DIR K DIR
- ;
- S DA(2)=RCSCR,DA(1)=RCTO
- ; BEGIN PRCA*4.5*326
- ; Check if the distribution is to a non-VA claim
- S NONVA=0 I $P($G(^RCY(344.49,RCSCR,1,RCTO1,0)),U,2)'["**ADJ",'$P(RCTO0,U,7) S NONVA=1
- S DIC("DR")=".02////0;.03////"_$J(-RCAMT,"",2)
- S DIC("DR")=DIC("DR")_";.04////"_$S($P(RCFR0,U,2)'="":$P(RCFR0,U,2),RCREF'="":RCREF,1:"UNKNOWN")
- ; If a non-VA distribution the background action is set none - comment is fixed text concatenated with PLB comment
- S DIC("DR")=DIC("DR")_";.05////"_$S(NONVA:0,$P($G(^RCY(344.49,RCSCR,1,RCTO1,0)),U,2)'["**ADJ":"1;.08////0",1:0)
- S DIC("DR")=DIC("DR")_";.06////0"_$S(RCCOM'="":";.09////"_RCCOM,1:"")
- ; END PRCA*4.5*326
- ;
- S DIC="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",1,"
- S DLAYGO=344.4911,DIC(0)="L",X=+$O(^RCY(344.49,RCSCR,1,RCTO,1,"B",""),-1)+1
- D FILE^DICN K DIC,DD,DO,DLAYGO
- S RCY=+Y
- ;
- I RCY'>0 D Q
- . N DA
- . S DA(2)=RCSCR,DA(1)=RCFR,DA=RCY,DIK="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",1," D ^DIK
- . S DIR(0)="EA",DIR("A",1)="PROBLEM ADDING ADJUSTMENT - NO DISTRIBUTION PERFORMED",DIR("A")="PRESS RETURN TO CONTINUE " D ^DIR K DIR
- ;
- S DA(1)=RCSCR,DA=RCFR,DIE="^RCY(344.49,"_DA(1)_",1,",DR=".06////"_$J($P(RCFR0,U,6)+RCAMT,"",2)_";.08////"_$J($P(RCFR0,U,8)+RCAMT,"",2) D ^DIE
- S DA=RCFR1,DIE="^RCY(344.49,"_DA(1)_",1,",DR=".06////"_$J($P(RCFR10,U,6)+RCAMT,"",2) D ^DIE
- S DA(1)=RCSCR,DA=RCTO,DIE="^RCY(344.49,"_DA(1)_",1,",DR=".06////"_$J($P(RCTO0,U,6)-RCAMT,"",2)_";.03////"_$J($P(RCTO0,U,3)-RCAMT,"",2)_";.08////"_$J($P(RCTO0,U,8)-RCAMT,"",2) D ^DIE
- S DA(1)=RCSCR,DA=RCTO1,DIE="^RCY(344.49,"_DA(1)_",1,",DR=".06////"_$J($P(RCTO10,U,6)-RCAMT,"",2)_";.03////"_$J($P(RCTO10,U,3)-RCAMT,"",2)_";.08////"_$J($P(RCTO10,U,8)-RCAMT,"",2) D ^DIE
- ;
- ; If the distribution is to a none-VA claim set the receipt line comment - this is picked up in DET^RCDPEM when the receipt is created
- I NONVA S DA(1)=RCSCR,DA=RCTO,DIE="^RCY(344.49,"_DA(1)_",1,",DR=".1///"_RCCOM D ^DIE ; PRCA*4.5*326
- D BLD^RCDPEWL1($G(^TMP($J,"RC_SORTPARM")))
- Q
- ;
- NEWREC ; Create a new receipt from scratch pad entry
- N CT,DA,DIC,DIE,DIR,DR,RCDEP,RCER,RCHAC,RCOK,RCPAYTY,RCRECTDA,RCSTOP,RECTDA,X,Y,Z,Z0 ; PRCA*4.5*367
- D FULL^VALM1
- I $G(RCSCR("NOEDIT"))=2 D NOTAV^RCDPEWL2 G NEWRECQ
- S (RCSTOP,RCOK)=0,VALMBCK="R"
- S RECTDA=$P($G(^RCY(344.49,RCSCR,0)),U,2)
- I 'RECTDA S RECTDA=$P($G(^RCY(344.4,RCSCR,0)),U,8)
- ; PRCA*4.5*303 - Corrected receipt number display to use RECTDA in the DIR("A",1) variable
- I RECTDA D G NEWRECQ
- . S DIR(0)="EA",DIR("A",1)="THIS ERA ALREADY HAS A RECEIPT - "_$P($G(^RCY(344,RECTDA,0)),U)_" - NO RECEIPT CREATED",DIR("A")="PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR
- S DIR("A",1)="THIS ACTION WILL CREATE THE RECEIPT FOR THIS ERA. ONCE THE RECEIPT IS",DIR("A",2)=" CREATED HERE, NO MORE AUTOMATIC ADJUSTMENTS MAY BE MADE FOR THIS ERA.",DIR("A",3)=" "
- S DIR("A")="ARE YOU SURE YOU ARE READY TO CREATE THIS RECEIPT?: ",DIR("B")="NO",DIR(0)="YA"
- W ! D ^DIR K DIR W !
- I Y'=1 S DIR(0)="EA",DIR("A")="NO RECEIPT CREATED - PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR G NEWRECQ
- I $$HASADJ^RCDPEWL8(RCSCR,.RCOK) D G NEWRECQ
- . S DIR(0)="EA",DIR("A",1)="AT LEAST ONE LINE ITEM WAS FOUND WITH A NEGATIVE PAYMENT AMOUNT",DIR("A")="NO RECEIPT CAN BE CREATED - PRESS RETURN TO CONTINUE " D ^DIR K DIR S RCSTOP=1
- I 'RCOK S DIR(0)="EA",DIR("A")="NO RECEIPT CAN BE CREATED - NO POSTABLE LINE ITEMS WERE FOUND" W ! D ^DIR K DIR G NEWRECQ
- ;
- S RCHAC=$$HACERA^RCDPEU(RCSCR)
- S RCPAYTY=$S(RCHAC:17,$P($G(^RCY(344.4,+RCSCR,5)),U,2)="":14,1:4) ; PRCA*4.5*367 - Use CHAMPVA receipt type for CHAMPVA payments
- S RCDEP=""
- I RCPAYTY=4 D
- . N RCOK1
- . F D Q:RCOK1
- .. S RCOK1=1
- .. S DIC="^RCY(344.1,",DIC("S")="I $P(^(0),U,12)=1",DIC(0)="AEMQ" D ^DIC
- .. Q:Y'>0
- .. S RCDEP=+Y
- .. I RCDEP,$$TOOOLD^RCDPEWLA(RCDEP) S RCOK1=0,RCDEP=""
- S RECTDA=$$BLDRCPT^RCDPUREC(DT,+RCDEP_$S(RCPAYTY=4:"ERACHK",1:""),+$O(^RC(341.1,"AC",+RCPAYTY,0))) ; Note:ERA with paper check is type 4, but receipt needs to start with an 'E'
- I 'RECTDA W ! S DIR(0)="EA",DIR("A",1)="A PROBLEM WAS ENCOUNTERED ADDING THE RECEIPT - NO RECEIPT ADDED",DIR("A")="PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR G NEWRECQ
- ;
- D RCPTDET^RCDPEM(RCSCR,RECTDA,.RCER)
- ;PRCA*4.5*367 - Calculate Receipt Total for CHAMPVA Receipts
- I RCHAC D
- . N RCFDA,RCPTOT,I
- . S (RCPTOT,I)=0
- . F S I=$O(^RCY(344.49,RCSCR,1,I)) Q:'I D
- .. Q:$P(^RCY(344.49,RCSCR,1,I,0),U)'["."
- .. S RCPTOT=RCPTOT+$P(^RCY(344.49,RCSCR,1,I,0),U,3)
- . S RCFDA(344,RECTDA_",",.22)=RCPTOT
- . D FILE^DIE(,"RCFDA")
- ;
- S DIE="^RCY(344.49,",DA=RCSCR,DR=".02////"_RECTDA D ^DIE
- S DIE="^RCY(344.4,",DA=RCSCR,DR=".08////"_RECTDA D ^DIE
- S Z=+$O(^RCY(344.31,"AERA",RCSCR,0))
- S DIE="^RCY(344,",DA=RECTDA,DR=".18////"_RCSCR_$S(Z:";.17////"_Z,1:"")_$S(RCPAYTY=4:";.06////"_RCDEP,1:"")_$S($P($G(^RCY(344.31,Z,0)),U,15)'="":";.16////"_$P(^RCY(344.31,Z,0),U,15),1:"") D ^DIE
- ;
- I $O(RCER(0)) D
- . S CT=1,DIR(0)="EA",DIR("A",1)="THE FOLLOWING PROBLEMS OCCURRED WHILE ADDING THE RECEIPT: "
- . S Z=0 F S Z=$O(RCER(Z)) Q:'Z S CT=CT+1,DIR("A",CT)=RCER(Z)
- . S DIR("A")="PRESS RETURN TO CONTINUE "
- . W ! D ^DIR K DIR
- ;
- S DIR(0)="YA",DIR("A")="DO YOU WANT TO GO TO RECEIPT PROCESSING NOW? ",DIR("A",1)=" ",DIR("A",2)="RECEIPT "_$P($G(^RCY(344,+RECTDA,0)),U)_" HAS BEEN CREATED FOR THIS ERA",DIR("B")="YES" W ! D ^DIR K DIR
- I Y=1 S RCRECTDA=RECTDA D EN^VALM("RCDP RECEIPT PROFILE")
- S RCSCR=0
- S VALMBCK="Q"
- ;
- NEWRECQ Q
- ;
- VRECPT ;EP - Protocol action - RCDPE EOB WL RECEIPT VIEW
- ; Preview receipt lines
- ; Assume RCSCR = ien from file 344.49 (and 344.4)
- N DIR,RCOK,RCZ,X,Y,Z,Z0
- D FULL^VALM1
- S VALMBCK="R"
- I $S($P($G(^RCY(344.4,RCSCR,4)),U,2)]"":1,1:0) D VR^RCDPEWLP(RCSCR) G VRECPTQ ; prca*4.5*298 auto-posted ERAs are handled differently
- ;
- ;
- ; prca*4.5*298 per patch requirements, keep code related to creating/maintaining
- ; batches but just remove from execution.
- ; I $G(^TMP("RCBATCH_SELECTED",$J)) D NOBATCH^RCDPEWL Q
- ;I $O(^RCY(344.49,RCSCR,3,0)) D Q:'RCOK
- ;. S RCOK=1
- ;. S Z=0 F S Z=$O(^RCY(344.49,RCSCR,3,Z)) Q:'Z I '$P($G(^(Z,0)),U,3) S RCOK=0 Q
- ;. I 'RCOK S DIR(0)="EA",DIR("A",1)="A RECEIPT CANNOT BE PREVIEWED UNTIL ALL BATCHES FOR THIS ERA ARE MARKED AS",DIR("A",2)="'READY TO POST'",DIR("A")="PRESS RETURN TO CONTINUE " W ! D ^DIR K DIR
- ; end of prca*4.5*298
- S Z=0 F S Z=$O(^RCY(344.49,RCSCR,1,Z)) Q:'Z I $P(Z,".",2) S Z0=$G(^(Z,0)) I $P(Z0,U,6)<0 S RCZ($P(Z0,U))=$P(Z0,U,2)_U_$P(Z0,U,6)
- I $O(RCZ(""))'="" D
- . W !,"THE FOLLOWING LINES HAVE A NET PAYMENT LESS THAN 0. THESE LINES MUST HAVE",!,"THIS NEGATIVE AMOUNT DISTRIBUTED TO OTHER LINE(S) IN THE ERA BEFORE A",!,"RECEIPT CAN BE CREATED."
- . S Z="" F S Z=$O(RCZ(Z)) Q:Z="" W !,$J("",5)_$J(Z,10)_" "_$E($P(RCZ(Z),U)_$J("",15),1,15)_" "_$J(+$P(RCZ(Z),U,2),"",2)
- . W !
- . S DIR(0)="E" D ^DIR K DIR
- ;
- I '$D(^XUSEC("RCDPEPP",DUZ)) D Q ; PRCA*4.5*349 - Added AM worklist preview
- . D EN^VALM("RCDPE EOB RECEIPT PREVIEW AM"),VRECPTQ
- D EN^VALM("RCDPE EOB RECEIPT PREVIEW")
- VRECPTQ ;
- S VALMBCK=$S('$G(RCSCR):"Q",1:"R")
- Q
- ;
- ; PRCA*4.5*303 - Receipt Processing
- RECPROC ;EP - Protocol action - RCDPE EON WORKLIST RECEIPT PROCESSING
- ; Receipt Processing
- ; Called by RCDPE EOB WORKLIST RECEIPT PROCESSING protocol
- ; Assume RCSCR is the IEN from file 344.49 (and 344.4)
- ; Variable RCRECTDA is needed by RECEIPT PROFILE so is not newed
- ; Variable RCDPFXIT is used by RCDPLPLM for immediate exit so newed it here so that does not happen
- ;
- N ARRAY,RECIEN,RECEIPT,CNT,DIR,X,Y,DTOUT,DUOUT,DROUT,DIRUT,I,LIST,RCDPFXIT
- D FULL^VALM1
- S VALMBCK="R"
- I '$D(^XUSEC("RCDPEPP",DUZ)) D Q ; PRCA*4.5*318 Added security key check
- . W !!,"This action can only be taken by users that have the RCDPEPP security key.",!
- . D PAUSE^VALM1
- ;
- ; Get list of receipts from the ERA detail multiple
- S RECIEN=0,CNT=0
- F S RECIEN=$O(^RCY(344.4,RCSCR,1,"RECEIPT",RECIEN)) Q:'RECIEN D
- . S RECEIPT=$P($G(^RCY(344,RECIEN,0)),U)
- . I RECEIPT]"" S CNT=CNT+1,ARRAY(CNT)=RECEIPT_"^"_RECIEN
- ;
- ; The array of receipts does not exist, this could be a non auto-posted ERA; so only 1 receipt will be assigned; retrieve at 344.4, .08
- I '$D(ARRAY),$$GET1^DIQ(344.4,RCSCR_",",.08)'="" S CNT=1,ARRAY(1)=$$GET1^DIQ(344.4,RCSCR_",",.08,"E")_"^"_$$GET1^DIQ(344.4,RCSCR_",",.08,"I")
- ;
- ; No receipt - display mesage and quit
- I CNT=0 K DIR S DIR("A",1)="No receipts exist for this ERA." G RECPROCQ
- ;
- ; One receipt - Use it
- I CNT=1 S RCRECTDA=$P(ARRAY(1),U,2) G RECPROC1
- ;
- ; Multiple receipts - User needs to select
- W !
- S LIST=""
- F I=1:1:CNT S LIST=LIST_$S(LIST]"":";",1:"")_I_":"_$P(ARRAY(I),U,1)
- S DIR(0)="SO^"_LIST,DIR("A")="Select Receipt"
- D ^DIR
- I Y<1!(Y>CNT) K DIR S DIR("A",1)="No selection made" G RECPROCQ
- S RCRECTDA=$P(ARRAY(Y),U,2)
- RECPROC1 ;
- D EN^VALM("RCDP RECEIPT PROFILE")
- ; If RCDPFXIT is set, exit option entirely was selected so quit back to the menu
- I $G(RCDPFXIT) S VALMBCK="Q"
- Q
- ;
- RECPROCQ ;
- ; Display the message in DIR("A",1) and then press enter
- S DIR(0)="EA",DIR("A")="Press ENTER to continue: "
- W ! D ^DIR K DIR
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEWL4 11128 printed Jan 18, 2025@02:46:56 Page 2
- RCDPEWL4 ;ALB/TMK/PJH - ELECTRONIC EOB WORKLIST ACTIONS ;Jun 06, 2014@19:11:19
- +1 ;;4.5;Accounts Receivable;**173,208,269,298,303,318,326,349,367**;Mar 20, 1995;Build 11
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ; RCSCR variable must be defined for this routine
- +4 QUIT
- +5 ;
- DISTADJ(RCFR,RCTO,RCAMT,RCCOM) ; Action that distributes an adjustment amount
- +1 ; against another line item's payment
- +2 ; Assumes RCSCR = ien of the entry in file 344.49
- +3 ; RCFR = ien of entry in 344.491 that has a negative net
- +4 ; RCTO = ien of entry in 344.491 that will be decremented
- +5 ; RCAMT = the amount being adjusted (positive #)
- +6 ; RCCOM = the comment to place on the decrease adjustment
- +7 ;
- +8 NEW RCFRX,RCREF,RCFR0,RCFR1,RCFR10,RCTO0,RCTO1,RCTO10,RCY
- +9 ; PRCA*4.5*326
- NEW DA,DD,DIK,DR,DIC,DIE,DIK,DIR,DLAYGO,DO,NONVA,X,Y
- +10 IF $GET(^TMP("RCBATCH_SELECTED",$JOB))
- DO NOBATCH^RCDPEWL
- QUIT
- +11 SET RCFR0=$GET(^RCY(344.49,RCSCR,1,RCFR,0))
- SET RCTO0=$GET(^RCY(344.49,RCSCR,1,RCTO,0))
- SET RCFRX=+$ORDER(^RCY(344.49,RCSCR,1,"B",RCFR0\1,0))
- SET RCFRX=$GET(^RCY(344.49,RCSCR,1,RCFRX,0))
- +12 SET RCREF=$PIECE($PIECE(RCFRX,U,2),"**ADJ",2)
- SET RCREF=$SELECT(RCREF="":"",RCREF=0:$PIECE(RCFRX,U,9),1:$PIECE($GET(^RCY(344.4,RCSCR,2,+RCREF,0)),U))
- +13 SET RCFR1=+$ORDER(^RCY(344.49,RCSCR,1,"B",RCFR0\1,0))
- SET RCTO1=+$ORDER(^RCY(344.49,RCSCR,1,"B",RCTO0\1,0))
- +14 SET RCFR10=$GET(^RCY(344.49,RCSCR,1,RCFR1,0))
- SET RCTO10=$GET(^RCY(344.49,RCSCR,1,RCTO1,0))
- +15 SET RCFR0=$GET(^RCY(344.49,RCSCR,1,RCFR,0))
- SET RCTO0=$GET(^RCY(344.49,RCSCR,1,RCTO,0))
- +16 SET DA(2)=RCSCR
- SET DA(1)=RCFR
- +17 SET DIC("DR")=".02////1;.03////"_RCAMT_";.04////"_$SELECT($PIECE(RCTO0,U,2)'="":$PIECE(RCTO0,U,2),RCREF'="":RCREF,1:"UNKNOWN")
- +18 SET DIC("DR")=DIC("DR")_";.05////0;.06////0;.09////RETRACTED FUNDS DEDUCTED FROM OTHER PAYMENT ON THIS ERA"
- SET DIC="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",1,"
- +19 SET DLAYGO=344.4911
- SET DIC(0)="L"
- SET X=+$ORDER(^RCY(344.49,RCSCR,1,RCFR,1,"B",""),-1)+1
- +20 DO FILE^DICN
- KILL DIC,DD,DO,DLAYGO
- +21 SET RCY=+Y
- +22 IF RCY'>0
- Begin DoDot:1
- +23 SET DIR(0)="EA"
- SET DIR("A",1)="PROBLEM ADDING ADJUSTMENT - NO DISTRIBUTION PERFORMED"
- SET DIR("A")="PRESS RETURN TO CONTINUE "
- DO ^DIR
- KILL DIR
- End DoDot:1
- QUIT
- +24 ;
- +25 SET DA(2)=RCSCR
- SET DA(1)=RCTO
- +26 ; BEGIN PRCA*4.5*326
- +27 ; Check if the distribution is to a non-VA claim
- +28 SET NONVA=0
- IF $PIECE($GET(^RCY(344.49,RCSCR,1,RCTO1,0)),U,2)'["**ADJ"
- IF '$PIECE(RCTO0,U,7)
- SET NONVA=1
- +29 SET DIC("DR")=".02////0;.03////"_$JUSTIFY(-RCAMT,"",2)
- +30 SET DIC("DR")=DIC("DR")_";.04////"_$SELECT($PIECE(RCFR0,U,2)'="":$PIECE(RCFR0,U,2),RCREF'="":RCREF,1:"UNKNOWN")
- +31 ; If a non-VA distribution the background action is set none - comment is fixed text concatenated with PLB comment
- +32 SET DIC("DR")=DIC("DR")_";.05////"_$SELECT(NONVA:0,$PIECE($GET(^RCY(344.49,RCSCR,1,RCTO1,0)),U,2)'["**ADJ":"1;.08////0",1:0)
- +33 SET DIC("DR")=DIC("DR")_";.06////0"_$SELECT(RCCOM'="":";.09////"_RCCOM,1:"")
- +34 ; END PRCA*4.5*326
- +35 ;
- +36 SET DIC="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",1,"
- +37 SET DLAYGO=344.4911
- SET DIC(0)="L"
- SET X=+$ORDER(^RCY(344.49,RCSCR,1,RCTO,1,"B",""),-1)+1
- +38 DO FILE^DICN
- KILL DIC,DD,DO,DLAYGO
- +39 SET RCY=+Y
- +40 ;
- +41 IF RCY'>0
- Begin DoDot:1
- +42 NEW DA
- +43 SET DA(2)=RCSCR
- SET DA(1)=RCFR
- SET DA=RCY
- SET DIK="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",1,"
- DO ^DIK
- +44 SET DIR(0)="EA"
- SET DIR("A",1)="PROBLEM ADDING ADJUSTMENT - NO DISTRIBUTION PERFORMED"
- SET DIR("A")="PRESS RETURN TO CONTINUE "
- DO ^DIR
- KILL DIR
- End DoDot:1
- QUIT
- +45 ;
- +46 SET DA(1)=RCSCR
- SET DA=RCFR
- SET DIE="^RCY(344.49,"_DA(1)_",1,"
- SET DR=".06////"_$JUSTIFY($PIECE(RCFR0,U,6)+RCAMT,"",2)_";.08////"_$JUSTIFY($PIECE(RCFR0,U,8)+RCAMT,"",2)
- DO ^DIE
- +47 SET DA=RCFR1
- SET DIE="^RCY(344.49,"_DA(1)_",1,"
- SET DR=".06////"_$JUSTIFY($PIECE(RCFR10,U,6)+RCAMT,"",2)
- DO ^DIE
- +48 SET DA(1)=RCSCR
- SET DA=RCTO
- SET DIE="^RCY(344.49,"_DA(1)_",1,"
- SET DR=".06////"_$JUSTIFY($PIECE(RCTO0,U,6)-RCAMT,"",2)_";.03////"_$JUSTIFY($PIECE(RCTO0,U,3)-RCAMT,"",2)_";.08////"_$JUSTIFY($PIECE(RCTO0,U,8)-RCAMT,"",2)
- DO ^DIE
- +49 SET DA(1)=RCSCR
- SET DA=RCTO1
- SET DIE="^RCY(344.49,"_DA(1)_",1,"
- SET DR=".06////"_$JUSTIFY($PIECE(RCTO10,U,6)-RCAMT,"",2)_";.03////"_$JUSTIFY($PIECE(RCTO10,U,3)-RCAMT,"",2)_";.08////"_$JUSTIFY($PIECE(RCTO10,U,8)-RCAMT,"",2)
- DO ^DIE
- +50 ;
- +51 ; If the distribution is to a none-VA claim set the receipt line comment - this is picked up in DET^RCDPEM when the receipt is created
- +52 ; PRCA*4.5*326
- IF NONVA
- SET DA(1)=RCSCR
- SET DA=RCTO
- SET DIE="^RCY(344.49,"_DA(1)_",1,"
- SET DR=".1///"_RCCOM
- DO ^DIE
- +53 DO BLD^RCDPEWL1($GET(^TMP($JOB,"RC_SORTPARM")))
- +54 QUIT
- +55 ;
- NEWREC ; Create a new receipt from scratch pad entry
- +1 ; PRCA*4.5*367
- NEW CT,DA,DIC,DIE,DIR,DR,RCDEP,RCER,RCHAC,RCOK,RCPAYTY,RCRECTDA,RCSTOP,RECTDA,X,Y,Z,Z0
- +2 DO FULL^VALM1
- +3 IF $GET(RCSCR("NOEDIT"))=2
- DO NOTAV^RCDPEWL2
- GOTO NEWRECQ
- +4 SET (RCSTOP,RCOK)=0
- SET VALMBCK="R"
- +5 SET RECTDA=$PIECE($GET(^RCY(344.49,RCSCR,0)),U,2)
- +6 IF 'RECTDA
- SET RECTDA=$PIECE($GET(^RCY(344.4,RCSCR,0)),U,8)
- +7 ; PRCA*4.5*303 - Corrected receipt number display to use RECTDA in the DIR("A",1) variable
- +8 IF RECTDA
- Begin DoDot:1
- +9 SET DIR(0)="EA"
- SET DIR("A",1)="THIS ERA ALREADY HAS A RECEIPT - "_$PIECE($GET(^RCY(344,RECTDA,0)),U)_" - NO RECEIPT CREATED"
- SET DIR("A")="PRESS RETURN TO CONTINUE"
- WRITE !
- DO ^DIR
- KILL DIR
- End DoDot:1
- GOTO NEWRECQ
- +10 SET DIR("A",1)="THIS ACTION WILL CREATE THE RECEIPT FOR THIS ERA. ONCE THE RECEIPT IS"
- SET DIR("A",2)=" CREATED HERE, NO MORE AUTOMATIC ADJUSTMENTS MAY BE MADE FOR THIS ERA."
- SET DIR("A",3)=" "
- +11 SET DIR("A")="ARE YOU SURE YOU ARE READY TO CREATE THIS RECEIPT?: "
- SET DIR("B")="NO"
- SET DIR(0)="YA"
- +12 WRITE !
- DO ^DIR
- KILL DIR
- WRITE !
- +13 IF Y'=1
- SET DIR(0)="EA"
- SET DIR("A")="NO RECEIPT CREATED - PRESS RETURN TO CONTINUE"
- WRITE !
- DO ^DIR
- KILL DIR
- GOTO NEWRECQ
- +14 IF $$HASADJ^RCDPEWL8(RCSCR,.RCOK)
- Begin DoDot:1
- +15 SET DIR(0)="EA"
- SET DIR("A",1)="AT LEAST ONE LINE ITEM WAS FOUND WITH A NEGATIVE PAYMENT AMOUNT"
- SET DIR("A")="NO RECEIPT CAN BE CREATED - PRESS RETURN TO CONTINUE "
- DO ^DIR
- KILL DIR
- SET RCSTOP=1
- End DoDot:1
- GOTO NEWRECQ
- +16 IF 'RCOK
- SET DIR(0)="EA"
- SET DIR("A")="NO RECEIPT CAN BE CREATED - NO POSTABLE LINE ITEMS WERE FOUND"
- WRITE !
- DO ^DIR
- KILL DIR
- GOTO NEWRECQ
- +17 ;
- +18 SET RCHAC=$$HACERA^RCDPEU(RCSCR)
- +19 ; PRCA*4.5*367 - Use CHAMPVA receipt type for CHAMPVA payments
- SET RCPAYTY=$SELECT(RCHAC:17,$PIECE($GET(^RCY(344.4,+RCSCR,5)),U,2)="":14,1:4)
- +20 SET RCDEP=""
- +21 IF RCPAYTY=4
- Begin DoDot:1
- +22 NEW RCOK1
- +23 FOR
- Begin DoDot:2
- +24 SET RCOK1=1
- +25 SET DIC="^RCY(344.1,"
- SET DIC("S")="I $P(^(0),U,12)=1"
- SET DIC(0)="AEMQ"
- DO ^DIC
- +26 if Y'>0
- QUIT
- +27 SET RCDEP=+Y
- +28 IF RCDEP
- IF $$TOOOLD^RCDPEWLA(RCDEP)
- SET RCOK1=0
- SET RCDEP=""
- End DoDot:2
- if RCOK1
- QUIT
- End DoDot:1
- +29 ; Note:ERA with paper check is type 4, but receipt needs to start with an 'E'
- SET RECTDA=$$BLDRCPT^RCDPUREC(DT,+RCDEP_$SELECT(RCPAYTY=4:"ERACHK",1:""),+$ORDER(^RC(341.1,"AC",+RCPAYTY,0)))
- +30 IF 'RECTDA
- WRITE !
- SET DIR(0)="EA"
- SET DIR("A",1)="A PROBLEM WAS ENCOUNTERED ADDING THE RECEIPT - NO RECEIPT ADDED"
- SET DIR("A")="PRESS RETURN TO CONTINUE"
- WRITE !
- DO ^DIR
- KILL DIR
- GOTO NEWRECQ
- +31 ;
- +32 DO RCPTDET^RCDPEM(RCSCR,RECTDA,.RCER)
- +33 ;PRCA*4.5*367 - Calculate Receipt Total for CHAMPVA Receipts
- +34 IF RCHAC
- Begin DoDot:1
- +35 NEW RCFDA,RCPTOT,I
- +36 SET (RCPTOT,I)=0
- +37 FOR
- SET I=$ORDER(^RCY(344.49,RCSCR,1,I))
- if 'I
- QUIT
- Begin DoDot:2
- +38 if $PIECE(^RCY(344.49,RCSCR,1,I,0),U)'["."
- QUIT
- +39 SET RCPTOT=RCPTOT+$PIECE(^RCY(344.49,RCSCR,1,I,0),U,3)
- End DoDot:2
- +40 SET RCFDA(344,RECTDA_",",.22)=RCPTOT
- +41 DO FILE^DIE(,"RCFDA")
- End DoDot:1
- +42 ;
- +43 SET DIE="^RCY(344.49,"
- SET DA=RCSCR
- SET DR=".02////"_RECTDA
- DO ^DIE
- +44 SET DIE="^RCY(344.4,"
- SET DA=RCSCR
- SET DR=".08////"_RECTDA
- DO ^DIE
- +45 SET Z=+$ORDER(^RCY(344.31,"AERA",RCSCR,0))
- +46 SET DIE="^RCY(344,"
- SET DA=RECTDA
- SET DR=".18////"_RCSCR_$SELECT(Z:";.17////"_Z,1:"")_$SELECT(RCPAYTY=4:";.06////"_RCDEP,1:"")_$SELECT($PIECE($GET(^RCY(344.31,Z,0)),U,15)'="":";.16////"_$PIECE(^RCY(344.31,Z,0),U,15),1:"")
- DO ^DIE
- +47 ;
- +48 IF $ORDER(RCER(0))
- Begin DoDot:1
- +49 SET CT=1
- SET DIR(0)="EA"
- SET DIR("A",1)="THE FOLLOWING PROBLEMS OCCURRED WHILE ADDING THE RECEIPT: "
- +50 SET Z=0
- FOR
- SET Z=$ORDER(RCER(Z))
- if 'Z
- QUIT
- SET CT=CT+1
- SET DIR("A",CT)=RCER(Z)
- +51 SET DIR("A")="PRESS RETURN TO CONTINUE "
- +52 WRITE !
- DO ^DIR
- KILL DIR
- End DoDot:1
- +53 ;
- +54 SET DIR(0)="YA"
- SET DIR("A")="DO YOU WANT TO GO TO RECEIPT PROCESSING NOW? "
- SET DIR("A",1)=" "
- SET DIR("A",2)="RECEIPT "_$PIECE($GET(^RCY(344,+RECTDA,0)),U)_" HAS BEEN CREATED FOR THIS ERA"
- SET DIR("B")="YES"
- WRITE !
- DO ^DIR
- KILL DIR
- +55 IF Y=1
- SET RCRECTDA=RECTDA
- DO EN^VALM("RCDP RECEIPT PROFILE")
- +56 SET RCSCR=0
- +57 SET VALMBCK="Q"
- +58 ;
- NEWRECQ QUIT
- +1 ;
- VRECPT ;EP - Protocol action - RCDPE EOB WL RECEIPT VIEW
- +1 ; Preview receipt lines
- +2 ; Assume RCSCR = ien from file 344.49 (and 344.4)
- +3 NEW DIR,RCOK,RCZ,X,Y,Z,Z0
- +4 DO FULL^VALM1
- +5 SET VALMBCK="R"
- +6 ; prca*4.5*298 auto-posted ERAs are handled differently
- IF $SELECT($PIECE($GET(^RCY(344.4,RCSCR,4)),U,2)]"":1,1:0)
- DO VR^RCDPEWLP(RCSCR)
- GOTO VRECPTQ
- +7 ;
- +8 ;
- +9 ; prca*4.5*298 per patch requirements, keep code related to creating/maintaining
- +10 ; batches but just remove from execution.
- +11 ; I $G(^TMP("RCBATCH_SELECTED",$J)) D NOBATCH^RCDPEWL Q
- +12 ;I $O(^RCY(344.49,RCSCR,3,0)) D Q:'RCOK
- +13 ;. S RCOK=1
- +14 ;. S Z=0 F S Z=$O(^RCY(344.49,RCSCR,3,Z)) Q:'Z I '$P($G(^(Z,0)),U,3) S RCOK=0 Q
- +15 ;. I 'RCOK S DIR(0)="EA",DIR("A",1)="A RECEIPT CANNOT BE PREVIEWED UNTIL ALL BATCHES FOR THIS ERA ARE MARKED AS",DIR("A",2)="'READY TO POST'",DIR("A")="PRESS RETURN TO CONTINUE " W ! D ^DIR K DIR
- +16 ; end of prca*4.5*298
- +17 SET Z=0
- FOR
- SET Z=$ORDER(^RCY(344.49,RCSCR,1,Z))
- if 'Z
- QUIT
- IF $PIECE(Z,".",2)
- SET Z0=$GET(^(Z,0))
- IF $PIECE(Z0,U,6)<0
- SET RCZ($PIECE(Z0,U))=$PIECE(Z0,U,2)_U_$PIECE(Z0,U,6)
- +18 IF $ORDER(RCZ(""))'=""
- Begin DoDot:1
- +19 WRITE !,"THE FOLLOWING LINES HAVE A NET PAYMENT LESS THAN 0. THESE LINES MUST HAVE",!,"THIS NEGATIVE AMOUNT DISTRIBUTED TO OTHER LINE(S) IN THE ERA BEFORE A",!,"RECEIPT CAN BE CREATED."
- +20 SET Z=""
- FOR
- SET Z=$ORDER(RCZ(Z))
- if Z=""
- QUIT
- WRITE !,$JUSTIFY("",5)_$JUSTIFY(Z,10)_" "_$EXTRACT($PIECE(RCZ(Z),U)_$JUSTIFY("",15),1,15)_" "_$JUSTIFY(+$PIECE(RCZ(Z),U,2),"",2)
- +21 WRITE !
- +22 SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- End DoDot:1
- +23 ;
- +24 ; PRCA*4.5*349 - Added AM worklist preview
- IF '$DATA(^XUSEC("RCDPEPP",DUZ))
- Begin DoDot:1
- +25 DO EN^VALM("RCDPE EOB RECEIPT PREVIEW AM")
- DO VRECPTQ
- End DoDot:1
- QUIT
- +26 DO EN^VALM("RCDPE EOB RECEIPT PREVIEW")
- VRECPTQ ;
- +1 SET VALMBCK=$SELECT('$GET(RCSCR):"Q",1:"R")
- +2 QUIT
- +3 ;
- +4 ; PRCA*4.5*303 - Receipt Processing
- RECPROC ;EP - Protocol action - RCDPE EON WORKLIST RECEIPT PROCESSING
- +1 ; Receipt Processing
- +2 ; Called by RCDPE EOB WORKLIST RECEIPT PROCESSING protocol
- +3 ; Assume RCSCR is the IEN from file 344.49 (and 344.4)
- +4 ; Variable RCRECTDA is needed by RECEIPT PROFILE so is not newed
- +5 ; Variable RCDPFXIT is used by RCDPLPLM for immediate exit so newed it here so that does not happen
- +6 ;
- +7 NEW ARRAY,RECIEN,RECEIPT,CNT,DIR,X,Y,DTOUT,DUOUT,DROUT,DIRUT,I,LIST,RCDPFXIT
- +8 DO FULL^VALM1
- +9 SET VALMBCK="R"
- +10 ; PRCA*4.5*318 Added security key check
- IF '$DATA(^XUSEC("RCDPEPP",DUZ))
- Begin DoDot:1
- +11 WRITE !!,"This action can only be taken by users that have the RCDPEPP security key.",!
- +12 DO PAUSE^VALM1
- End DoDot:1
- QUIT
- +13 ;
- +14 ; Get list of receipts from the ERA detail multiple
- +15 SET RECIEN=0
- SET CNT=0
- +16 FOR
- SET RECIEN=$ORDER(^RCY(344.4,RCSCR,1,"RECEIPT",RECIEN))
- if 'RECIEN
- QUIT
- Begin DoDot:1
- +17 SET RECEIPT=$PIECE($GET(^RCY(344,RECIEN,0)),U)
- +18 IF RECEIPT]""
- SET CNT=CNT+1
- SET ARRAY(CNT)=RECEIPT_"^"_RECIEN
- End DoDot:1
- +19 ;
- +20 ; The array of receipts does not exist, this could be a non auto-posted ERA; so only 1 receipt will be assigned; retrieve at 344.4, .08
- +21 IF '$DATA(ARRAY)
- IF $$GET1^DIQ(344.4,RCSCR_",",.08)'=""
- SET CNT=1
- SET ARRAY(1)=$$GET1^DIQ(344.4,RCSCR_",",.08,"E")_"^"_$$GET1^DIQ(344.4,RCSCR_",",.08,"I")
- +22 ;
- +23 ; No receipt - display mesage and quit
- +24 IF CNT=0
- KILL DIR
- SET DIR("A",1)="No receipts exist for this ERA."
- GOTO RECPROCQ
- +25 ;
- +26 ; One receipt - Use it
- +27 IF CNT=1
- SET RCRECTDA=$PIECE(ARRAY(1),U,2)
- GOTO RECPROC1
- +28 ;
- +29 ; Multiple receipts - User needs to select
- +30 WRITE !
- +31 SET LIST=""
- +32 FOR I=1:1:CNT
- SET LIST=LIST_$SELECT(LIST]"":";",1:"")_I_":"_$PIECE(ARRAY(I),U,1)
- +33 SET DIR(0)="SO^"_LIST
- SET DIR("A")="Select Receipt"
- +34 DO ^DIR
- +35 IF Y<1!(Y>CNT)
- KILL DIR
- SET DIR("A",1)="No selection made"
- GOTO RECPROCQ
- +36 SET RCRECTDA=$PIECE(ARRAY(Y),U,2)
- RECPROC1 ;
- +1 DO EN^VALM("RCDP RECEIPT PROFILE")
- +2 ; If RCDPFXIT is set, exit option entirely was selected so quit back to the menu
- +3 IF $GET(RCDPFXIT)
- SET VALMBCK="Q"
- +4 QUIT
- +5 ;
- RECPROCQ ;
- +1 ; Display the message in DIR("A",1) and then press enter
- +2 SET DIR(0)="EA"
- SET DIR("A")="Press ENTER to continue: "
- +3 WRITE !
- DO ^DIR
- KILL DIR
- +4 QUIT