IBCEMCA1 ;ALB/ESG - Multiple CSA Message Management - Actions ;20-SEP-2005
;;2.0;INTEGRATED BILLING;**320,718**;21-MAR-1994;Build 73
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
Q
REVSTAT ; change review status
NEW DIR,X,Y,DA,DIRUT,DIROUT,DTOUT,DUOUT,NS,IBRVUST,IBFNRVAC,IBRVCMT
NEW DIC,DWLW,DWPK,DIWESUB,DIWETXT,LN,IBDA,IBOLD,DIE,DA,DR
D FULL^VALM1
S NS=+$G(^TMP($J,"IBCEMCL",4))
I 'NS D G REVSTATX
. W !!?5,"There are no selected messages." D PAUSE^VALM1
. Q
;
W !!?5,"Number of messages selected: ",NS,!
;
; reader call for the new review status field
S DIR(0)="361,.09"
S DIR("A")="Enter the REVIEW STATUS for the selected message"_$S(NS>1:"s",1:"")
D ^DIR K DIR
I $D(DIRUT) G REVSTATX
M IBRVUST=Y
I IBRVUST'=2 G RVCQ ; skip down to the confirmation
;
RSQ2 ; Reader call for the final review action field
W !
S DIR(0)="361,.1"
S DIR("A")="Enter the FINAL REVIEW ACTION for the selected message"_$S(NS>1:"s",1:"")
D ^DIR K DIR
I X="",Y="" W !!?5,"This field is required when the review has been completed." G RSQ2
I $D(DIRUT) G REVSTATX
M IBFNRVAC=Y
;
RSQ3 ; review comment text
W !
K ^TMP($J,"IBCEMCA1-COMMENTS"),IBRVCMT
S DIC="^TMP($J,""IBCEMCA1-COMMENTS"","
S DWLW=75,DWPK=1,DIWESUB="REVIEW COMMENTS"
S DIWETXT="These comments are optional"
I IBFNRVAC="O" S DIWETXT="These comments are required because OTHER ACTION was selected."
D EN^DIWE
M IBRVCMT=^TMP($J,"IBCEMCA1-COMMENTS")
K ^TMP($J,"IBCEMCA1-COMMENTS")
I IBFNRVAC="O",'$D(IBRVCMT(0)) D G RSQ3
. W !!?5,"Comments are required when the Final Review Action is OTHER ACTION."
. D PAUSE^VALM1
. Q
I $P($G(IBRVCMT(0)),U,4) S IBRVCMT=$P($G(IBRVCMT(0)),U,4)
;
RVCQ ; display a summary of the user responses and get confirmation
W !!," Number of selected",!," Status Messages: ",NS
W !?7,"Review Status: ",$G(IBRVUST(0))
I IBRVUST=2 D
. W !," Final Review Action: ",$G(IBFNRVAC(0))
. W !?5,"Review Comments: "
. I '$D(IBRVCMT(0)) W "<none>"
. E S LN=0 F S LN=$O(IBRVCMT(LN)) Q:'LN W !?5,IBRVCMT(LN,0)
. Q
W !
S DIR(0)="YO"
S DIR("A")="OK to proceed",DIR("B")="No"
D ^DIR K DIR
I Y'=1 G REVSTATX
;
; Loop thru selected status messages and update them
S IBDA=0
F S IBDA=$O(^TMP($J,"IBCEMCL",4,1,IBDA)) Q:'IBDA D
. S IBOLD=$P($G(^IBM(361,IBDA,0)),U,9) ; old review status
. S DIE=361,DA=IBDA
. S DR=".09////"_IBRVUST
. I $G(IBFNRVAC)'="" S DR=DR_";.1////"_$G(IBFNRVAC)
. D ^DIE
. I $D(IBRVCMT(0)) D NOTECHG^IBCECSA2(IBDA,0,.IBRVCMT,1)
. I IBOLD'=IBRVUST D NOTECHG^IBCECSA2(IBDA,0)
. L -^IBM(361,IBDA) ; unlock
. Q
W " ... Done!"
;
; rebuild the list
KILL ^TMP($J,"IBCEMCA"),VALMHDR
S VALMBG=1
D INIT^IBCEMCL
I $G(IBCSAMCS)=1 S IBCSAMCS=2 ; flag to rebuild CSA
;
REVSTATX ;
S VALMBCK="R"
Q
;
NEW NS,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,IBRVCMT,DIC,DWLW,DWPK,DIWESUB,IBDA,LN
D FULL^VALM1
S NS=+$G(^TMP($J,"IBCEMCL",4))
I 'NS D G COMMX
. W !!?5,"There are no selected messages." D PAUSE^VALM1
. Q
;
W !!?5,"Number of messages selected: ",NS,!
;
S DIR(0)="YO",DIR("B")="Yes"
S DIR("A")="Do you want to add a new Review Comment for all of these messages"
I NS=1 S DIR("A")="Do you want to add a new Review Comment for this message"
D ^DIR K DIR
I Y'=1 G COMMX
;
; review comment text
W !
K ^TMP($J,"IBCEMCA1-COMMENTS"),IBRVCMT
S DIC="^TMP($J,""IBCEMCA1-COMMENTS"","
S DWLW=75,DWPK=1,DIWESUB="REVIEW COMMENTS"
D EN^DIWE
M IBRVCMT=^TMP($J,"IBCEMCA1-COMMENTS")
K ^TMP($J,"IBCEMCA1-COMMENTS")
I $P($G(IBRVCMT(0)),U,4) S IBRVCMT=$P($G(IBRVCMT(0)),U,4)
I '$D(IBRVCMT(0)) G COMMX ; no comments entered
;
; final confirmation
W !
S LN=0 F S LN=$O(IBRVCMT(LN)) Q:'LN W !?5,IBRVCMT(LN,0)
W !
S DIR(0)="YO"
S DIR("A")="OK to add this comment for all selected status messages",DIR("B")="No"
I NS=1 S DIR("A")="OK to add this comment for the selected status message"
D ^DIR K DIR
I Y'=1 G COMMX
;
; Loop thru selected status messages and update them
S IBDA=0
F S IBDA=$O(^TMP($J,"IBCEMCL",4,1,IBDA)) Q:'IBDA D
. D NOTECHG^IBCECSA2(IBDA,0,.IBRVCMT,1)
. L -^IBM(361,IBDA) ; unlock
. Q
W " ... Done!"
;
; rebuild the list
KILL ^TMP($J,"IBCEMCA"),VALMHDR
S VALMBG=1
D INIT^IBCEMCL
;
COMMX ;
S VALMBCK="R"
Q
;
RETRAN ; retransmit claims
NEW NS,IBIFN,NSC,DIR,X,Y,DUOUT,DTOUT,DIRUT,DIROUT,IBDA,IB364
D FULL^VALM1
S NS=+$G(^TMP($J,"IBCEMCL",4))
I 'NS D G RETRANX
. W !!?5,"There are no selected messages." D PAUSE^VALM1
. Q
;
; count number of claims too
S IBIFN=0 F NSC=0:1 S IBIFN=$O(^TMP($J,"IBCEMCL",4,2,IBIFN)) Q:'IBIFN
;
W !!?5,"Number of messages selected: ",NS
W !?7,"Number of claims selected: ",NSC,!
;
S DIR("A",1)="In order to retransmit these claims, the transmission status for all of these"
S DIR("A",2)="claims will be reset to be ""READY FOR EXTRACT"". These claims will then be"
S DIR("A",3)="sent with the next regularly scheduled claims transmission process."
S DIR("A",4)=""
S DIR("A")="Do you want to retransmit these claims"
I NSC=1 D
. S DIR("A",1)="In order to retransmit this claim, the transmission status for this claim will"
. S DIR("A",2)="be reset to be ""READY FOR EXTRACT"". This claim will then be sent with the"
. S DIR("A",3)="next regularly scheduled claims transmission process."
. S DIR("A")="Do you want to retransmit this claim"
. Q
S DIR(0)="YO",DIR("B")="No" D ^DIR K DIR
I Y'=1 G RETRANX
;
; Loop thru selected claims and add new transmission records in a
; "Ready to Extract" status
S IBIFN=0
F S IBIFN=$O(^TMP($J,"IBCEMCL",4,2,IBIFN)) Q:'IBIFN D
. S IBDA=+$O(^TMP($J,"IBCEMCL",4,2,IBIFN,""),-1) ; most recent 361 ien
. S IB364=+$P($G(^IBM(361,IBDA,0)),U,11) ; transmit bill 364 ien
. I 'IBDA!'IB364 Q
. D UPDEDI^IBCEM(IB364,"R") ; update EDI files for transmission
. ;JWS;IB*2.0*718;EBILL-2653;add parameter to set [10] of 364 entry for claim resubmission
. S Y=$$ADDTBILL^IBCB1(IBIFN,1,1) ; add new transmission record
. Q
W " ... Done!"
;
; rebuild the list
KILL ^TMP($J,"IBCEMCA"),VALMHDR
S VALMBG=1
D UNLOCK^IBCEMCL
D INIT^IBCEMCL
I $G(IBCSAMCS)=1 S IBCSAMCS=2 ; flag to rebuild CSA
;
RETRANX ;
S VALMBCK="R"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEMCA1 6401 printed Apr 09, 2024@21:34:29 Page 2
IBCEMCA1 ;ALB/ESG - Multiple CSA Message Management - Actions ;20-SEP-2005
+1 ;;2.0;INTEGRATED BILLING;**320,718**;21-MAR-1994;Build 73
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 QUIT
REVSTAT ; change review status
+1 NEW DIR,X,Y,DA,DIRUT,DIROUT,DTOUT,DUOUT,NS,IBRVUST,IBFNRVAC,IBRVCMT
+2 NEW DIC,DWLW,DWPK,DIWESUB,DIWETXT,LN,IBDA,IBOLD,DIE,DA,DR
+3 DO FULL^VALM1
+4 SET NS=+$GET(^TMP($JOB,"IBCEMCL",4))
+5 IF 'NS
Begin DoDot:1
+6 WRITE !!?5,"There are no selected messages."
DO PAUSE^VALM1
+7 QUIT
End DoDot:1
GOTO REVSTATX
+8 ;
+9 WRITE !!?5,"Number of messages selected: ",NS,!
+10 ;
+11 ; reader call for the new review status field
+12 SET DIR(0)="361,.09"
+13 SET DIR("A")="Enter the REVIEW STATUS for the selected message"_$SELECT(NS>1:"s",1:"")
+14 DO ^DIR
KILL DIR
+15 IF $DATA(DIRUT)
GOTO REVSTATX
+16 MERGE IBRVUST=Y
+17 ; skip down to the confirmation
IF IBRVUST'=2
GOTO RVCQ
+18 ;
RSQ2 ; Reader call for the final review action field
+1 WRITE !
+2 SET DIR(0)="361,.1"
+3 SET DIR("A")="Enter the FINAL REVIEW ACTION for the selected message"_$SELECT(NS>1:"s",1:"")
+4 DO ^DIR
KILL DIR
+5 IF X=""
IF Y=""
WRITE !!?5,"This field is required when the review has been completed."
GOTO RSQ2
+6 IF $DATA(DIRUT)
GOTO REVSTATX
+7 MERGE IBFNRVAC=Y
+8 ;
RSQ3 ; review comment text
+1 WRITE !
+2 KILL ^TMP($JOB,"IBCEMCA1-COMMENTS"),IBRVCMT
+3 SET DIC="^TMP($J,""IBCEMCA1-COMMENTS"","
+4 SET DWLW=75
SET DWPK=1
SET DIWESUB="REVIEW COMMENTS"
+5 SET DIWETXT="These comments are optional"
+6 IF IBFNRVAC="O"
SET DIWETXT="These comments are required because OTHER ACTION was selected."
+7 DO EN^DIWE
+8 MERGE IBRVCMT=^TMP($JOB,"IBCEMCA1-COMMENTS")
+9 KILL ^TMP($JOB,"IBCEMCA1-COMMENTS")
+10 IF IBFNRVAC="O"
IF '$DATA(IBRVCMT(0))
Begin DoDot:1
+11 WRITE !!?5,"Comments are required when the Final Review Action is OTHER ACTION."
+12 DO PAUSE^VALM1
+13 QUIT
End DoDot:1
GOTO RSQ3
+14 IF $PIECE($GET(IBRVCMT(0)),U,4)
SET IBRVCMT=$PIECE($GET(IBRVCMT(0)),U,4)
+15 ;
RVCQ ; display a summary of the user responses and get confirmation
+1 WRITE !!," Number of selected",!," Status Messages: ",NS
+2 WRITE !?7,"Review Status: ",$GET(IBRVUST(0))
+3 IF IBRVUST=2
Begin DoDot:1
+4 WRITE !," Final Review Action: ",$GET(IBFNRVAC(0))
+5 WRITE !?5,"Review Comments: "
+6 IF '$DATA(IBRVCMT(0))
WRITE "<none>"
+7 IF '$TEST
SET LN=0
FOR
SET LN=$ORDER(IBRVCMT(LN))
if 'LN
QUIT
WRITE !?5,IBRVCMT(LN,0)
+8 QUIT
End DoDot:1
+9 WRITE !
+10 SET DIR(0)="YO"
+11 SET DIR("A")="OK to proceed"
SET DIR("B")="No"
+12 DO ^DIR
KILL DIR
+13 IF Y'=1
GOTO REVSTATX
+14 ;
+15 ; Loop thru selected status messages and update them
+16 SET IBDA=0
+17 FOR
SET IBDA=$ORDER(^TMP($JOB,"IBCEMCL",4,1,IBDA))
if 'IBDA
QUIT
Begin DoDot:1
+18 ; old review status
SET IBOLD=$PIECE($GET(^IBM(361,IBDA,0)),U,9)
+19 SET DIE=361
SET DA=IBDA
+20 SET DR=".09////"_IBRVUST
+21 IF $GET(IBFNRVAC)'=""
SET DR=DR_";.1////"_$GET(IBFNRVAC)
+22 DO ^DIE
+23 IF $DATA(IBRVCMT(0))
DO NOTECHG^IBCECSA2(IBDA,0,.IBRVCMT,1)
+24 IF IBOLD'=IBRVUST
DO NOTECHG^IBCECSA2(IBDA,0)
+25 ; unlock
LOCK -^IBM(361,IBDA)
+26 QUIT
End DoDot:1
+27 WRITE " ... Done!"
+28 ;
+29 ; rebuild the list
+30 KILL ^TMP($JOB,"IBCEMCA"),VALMHDR
+31 SET VALMBG=1
+32 DO INIT^IBCEMCL
+33 ; flag to rebuild CSA
IF $GET(IBCSAMCS)=1
SET IBCSAMCS=2
+34 ;
REVSTATX ;
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
+1 NEW NS,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,IBRVCMT,DIC,DWLW,DWPK,DIWESUB,IBDA,LN
+2 DO FULL^VALM1
+3 SET NS=+$GET(^TMP($JOB,"IBCEMCL",4))
+4 IF 'NS
Begin DoDot:1
+5 WRITE !!?5,"There are no selected messages."
DO PAUSE^VALM1
+6 QUIT
End DoDot:1
GOTO COMMX
+7 ;
+8 WRITE !!?5,"Number of messages selected: ",NS,!
+9 ;
+10 SET DIR(0)="YO"
SET DIR("B")="Yes"
+11 SET DIR("A")="Do you want to add a new Review Comment for all of these messages"
+12 IF NS=1
SET DIR("A")="Do you want to add a new Review Comment for this message"
+13 DO ^DIR
KILL DIR
+14 IF Y'=1
GOTO COMMX
+15 ;
+16 ; review comment text
+17 WRITE !
+18 KILL ^TMP($JOB,"IBCEMCA1-COMMENTS"),IBRVCMT
+19 SET DIC="^TMP($J,""IBCEMCA1-COMMENTS"","
+20 SET DWLW=75
SET DWPK=1
SET DIWESUB="REVIEW COMMENTS"
+21 DO EN^DIWE
+22 MERGE IBRVCMT=^TMP($JOB,"IBCEMCA1-COMMENTS")
+23 KILL ^TMP($JOB,"IBCEMCA1-COMMENTS")
+24 IF $PIECE($GET(IBRVCMT(0)),U,4)
SET IBRVCMT=$PIECE($GET(IBRVCMT(0)),U,4)
+25 ; no comments entered
IF '$DATA(IBRVCMT(0))
GOTO COMMX
+26 ;
+27 ; final confirmation
+28 WRITE !
+29 SET LN=0
FOR
SET LN=$ORDER(IBRVCMT(LN))
if 'LN
QUIT
WRITE !?5,IBRVCMT(LN,0)
+30 WRITE !
+31 SET DIR(0)="YO"
+32 SET DIR("A")="OK to add this comment for all selected status messages"
SET DIR("B")="No"
+33 IF NS=1
SET DIR("A")="OK to add this comment for the selected status message"
+34 DO ^DIR
KILL DIR
+35 IF Y'=1
GOTO COMMX
+36 ;
+37 ; Loop thru selected status messages and update them
+38 SET IBDA=0
+39 FOR
SET IBDA=$ORDER(^TMP($JOB,"IBCEMCL",4,1,IBDA))
if 'IBDA
QUIT
Begin DoDot:1
+40 DO NOTECHG^IBCECSA2(IBDA,0,.IBRVCMT,1)
+41 ; unlock
LOCK -^IBM(361,IBDA)
+42 QUIT
End DoDot:1
+43 WRITE " ... Done!"
+44 ;
+45 ; rebuild the list
+46 KILL ^TMP($JOB,"IBCEMCA"),VALMHDR
+47 SET VALMBG=1
+48 DO INIT^IBCEMCL
+49 ;
COMMX ;
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
RETRAN ; retransmit claims
+1 NEW NS,IBIFN,NSC,DIR,X,Y,DUOUT,DTOUT,DIRUT,DIROUT,IBDA,IB364
+2 DO FULL^VALM1
+3 SET NS=+$GET(^TMP($JOB,"IBCEMCL",4))
+4 IF 'NS
Begin DoDot:1
+5 WRITE !!?5,"There are no selected messages."
DO PAUSE^VALM1
+6 QUIT
End DoDot:1
GOTO RETRANX
+7 ;
+8 ; count number of claims too
+9 SET IBIFN=0
FOR NSC=0:1
SET IBIFN=$ORDER(^TMP($JOB,"IBCEMCL",4,2,IBIFN))
if 'IBIFN
QUIT
+10 ;
+11 WRITE !!?5,"Number of messages selected: ",NS
+12 WRITE !?7,"Number of claims selected: ",NSC,!
+13 ;
+14 SET DIR("A",1)="In order to retransmit these claims, the transmission status for all of these"
+15 SET DIR("A",2)="claims will be reset to be ""READY FOR EXTRACT"". These claims will then be"
+16 SET DIR("A",3)="sent with the next regularly scheduled claims transmission process."
+17 SET DIR("A",4)=""
+18 SET DIR("A")="Do you want to retransmit these claims"
+19 IF NSC=1
Begin DoDot:1
+20 SET DIR("A",1)="In order to retransmit this claim, the transmission status for this claim will"
+21 SET DIR("A",2)="be reset to be ""READY FOR EXTRACT"". This claim will then be sent with the"
+22 SET DIR("A",3)="next regularly scheduled claims transmission process."
+23 SET DIR("A")="Do you want to retransmit this claim"
+24 QUIT
End DoDot:1
+25 SET DIR(0)="YO"
SET DIR("B")="No"
DO ^DIR
KILL DIR
+26 IF Y'=1
GOTO RETRANX
+27 ;
+28 ; Loop thru selected claims and add new transmission records in a
+29 ; "Ready to Extract" status
+30 SET IBIFN=0
+31 FOR
SET IBIFN=$ORDER(^TMP($JOB,"IBCEMCL",4,2,IBIFN))
if 'IBIFN
QUIT
Begin DoDot:1
+32 ; most recent 361 ien
SET IBDA=+$ORDER(^TMP($JOB,"IBCEMCL",4,2,IBIFN,""),-1)
+33 ; transmit bill 364 ien
SET IB364=+$PIECE($GET(^IBM(361,IBDA,0)),U,11)
+34 IF 'IBDA!'IB364
QUIT
+35 ; update EDI files for transmission
DO UPDEDI^IBCEM(IB364,"R")
+36 ;JWS;IB*2.0*718;EBILL-2653;add parameter to set [10] of 364 entry for claim resubmission
+37 ; add new transmission record
SET Y=$$ADDTBILL^IBCB1(IBIFN,1,1)
+38 QUIT
End DoDot:1
+39 WRITE " ... Done!"
+40 ;
+41 ; rebuild the list
+42 KILL ^TMP($JOB,"IBCEMCA"),VALMHDR
+43 SET VALMBG=1
+44 DO UNLOCK^IBCEMCL
+45 DO INIT^IBCEMCL
+46 ; flag to rebuild CSA
IF $GET(IBCSAMCS)=1
SET IBCSAMCS=2
+47 ;
RETRANX ;
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
