IBCEMCA ;ALB/ESG - Multiple CSA Message Management ;20-SEP-2005
;;2.0;INTEGRATED BILLING;**320,547**;21-MAR-1994;Build 119
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
SCREEN ; Change the message selection criteria
NEW DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,EDI,IBDONE,IBPAYER,INST,PROF,RESET,X,Y
S VALMBCK="R",RESET=0
D FULL^VALM1
W !
S DIR(0)="Y",DIR("A")="Do you want to change the MCS selection criteria"
S DIR("B")="Yes" D ^DIR K DIR
I 'Y G SCREENX ; get out; no list rebuild
K ^TMP($J,"IBCEMCA") ; kill selection area and rebuild below
K VALMHDR ; recalculate totals in header area
S VALMBG=1 ; begin new list display at line 1
;
Q1 ; payer
W !!,"PAYER SELECTION:"
S IBPAYER=""
S DIR(0)="SA^A:All Payers;S:Selected Payers"
S DIR("A")="Include All Payers or Selected Payers? "
S DIR("B")="All"
D ^DIR K DIR
I $D(DIROUT)!$D(DIRUT) S RESET=1 G QX ; kill scratch and rebuild list
I Y="A" K ^TMP($J,"IBCEMCA","INS") G Q2
W !
S DIR(0)="Y"
S DIR("A")=" Include all payers with the same electronic Payer ID"
S DIR("B")="Yes"
D ^DIR K DIR
I $D(DIROUT) S RESET=1 G QX ; kill scratch and rebuild the list
I $D(DIRUT) G Q1
S IBPAYER=Y
W !
;
S IBDONE=0
F D Q:IBDONE
. S DIC=36,DIC(0)="AEMQ",DIC("A")=" Select Insurance Company: "
. I $O(^TMP($J,"IBCEMCA","INS",1,"")) S DIC("A")=" Select Another Insurance Company: "
. S DIC("W")="D INSLIST^IBCEMCA(Y)"
. D ^DIC K DIC ; lookup
. I X="^^" S IBDONE=2 Q ; user entered ^^
. I +Y'>0 S IBDONE=1 Q ; user is done
. S ^TMP($J,"IBCEMCA","INS",1,+Y)=$P(Y,U,2)
. I 'IBPAYER Q
. S EDI=$$UP^XLFSTR($G(^DIC(36,+Y,3)))
. S PROF=$P(EDI,U,2)
. S INST=$P(EDI,U,4)
. I PROF'="",PROF'["PRNT" S ^TMP($J,"IBCEMCA","INS",2,PROF,+Y)=""
. I INST'="",INST'["PRNT" S ^TMP($J,"IBCEMCA","INS",2,INST,+Y)=""
. Q
;
I IBDONE=2 S RESET=1 G QX ;kill scratch and rebuild the list
;
I '$O(^TMP($J,"IBCEMCA","INS",1,"")) D G Q1
. W *7,!!?3,"No payers have been selected. Please try again."
. Q
;
Q2 ; division
W !!,"DIVISION SELECTION:"
S DIR(0)="SA^A:All Divisions;S:Selected Divisions"
S DIR("A")="Include All Divisions or Selected Divisions? "
S DIR("B")="All"
D ^DIR K DIR
I $D(DIROUT) S RESET=1 G QX ; kill scratch and rebuild list
I $D(DIRUT) G Q1
I Y="A" K ^TMP($J,"IBCEMCA","DIV") G Q3
;
W !
S IBDONE=0
F D Q:IBDONE
. S DIC=40.8,DIC(0)="AEMQ",DIC("A")=" Select Division: "
. I $O(^TMP($J,"IBCEMCA","DIV","")) S DIC("A")=" Select Another Division: "
. D ^DIC K DIC ; lookup
. I X="^^" S IBDONE=2 Q ; user entered ^^
. I +Y'>0 S IBDONE=1 Q ; user is done
. S ^TMP($J,"IBCEMCA","DIV",+Y)=$P(Y,U,2)
. Q
;
I IBDONE=2 S RESET=1 G QX ;kill scratch and rebuild the list
;
I '$O(^TMP($J,"IBCEMCA","DIV","")) D G Q2
. W *7,!!?3,"No divisions have been selected. Please try again."
. Q
;
Q3 ; message text
W !!,"ERROR MESSAGE TEXT SELECTION:"
S DIR(0)="SA^A:All Error Message Text;S:Select Error Message Text"
S DIR("A")="Include All Error Message Text or Select Error Message Text? "
S DIR("B")="All"
D ^DIR K DIR
I $D(DIROUT) S RESET=1 G QX ; kill scratch and rebuild list
I $D(DIRUT) G Q2
I Y="A" K ^TMP($J,"IBCEMCA","TEXT") G Q4
;
W !
S IBDONE=0
F D Q:IBDONE
. S DIR(0)="FAOU"
. S DIR("A")=" Text String: "
. I $O(^TMP($J,"IBCEMCA","TEXT",""))'="" S DIR("A")=" Another Text String: "
. D ^DIR K DIR ; user response
. I $D(DIROUT) S IBDONE=2 Q ; user entered ^^
. I $D(DIRUT) S IBDONE=1 Q ; leading up-arrow or time-out
. I Y="" S IBDONE=1 Q ; null response
. S ^TMP($J,"IBCEMCA","TEXT",Y)=""
. Q
;
I IBDONE=2 S RESET=1 G QX ;kill scratch and rebuild the list
;
I $O(^TMP($J,"IBCEMCA","TEXT",""))="" D G Q3
. W *7,!!?3,"No text has been selected. Please try again."
. Q
;
Q4 ; date range for when message received
W !!,"DATE MESSAGE RECEIVED SELECTION:"
S DIR(0)="SA^A:All Dates;S:Select Date Range"
S DIR("A")="Include All Dates or Select a Date Range? "
S DIR("B")="All"
D ^DIR K DIR
I $D(DIROUT) S RESET=1 G QX ; kill scratch and rebuild list
I $D(DIRUT) G Q3
I Y="A" K ^TMP($J,"IBCEMCA","DATE") G QX
;
Q4A ; beginning date
W !
S DIR(0)="DAO^:"_DT_":AEX",DIR("A")=" Enter the beginning date: "
D ^DIR K DIR
I $D(DIROUT) S RESET=1 G QX ; kill scratch and rebuild list
I $D(DIRUT)!'Y G Q4
S $P(^TMP($J,"IBCEMCA","DATE"),U,1)=Y
;
Q4B ; ending date
W !
S DIR(0)="DAO^"_Y_":"_DT_":AEX",DIR("A")=" Enter the ending date: "
D ^DIR K DIR
I $D(DIROUT) S RESET=1 G QX ; kill scratch and rebuild list
I $D(DIRUT)!'Y G Q4A
S $P(^TMP($J,"IBCEMCA","DATE"),U,2)=Y
;
QX ; end of questions, rebuild the list with user supplied selections
I RESET KILL ^TMP($J,"IBCEMCA")
D INIT^IBCEMCL
;
SCREENX ;
Q
;
TOGGLE ; Select/De-select entries in the list
NEW IBSEL,DIR,X,Y,DIRUT,DIROUT,DTOUT,DUOUT,IBCEMLST,IBCEMSUB,IBCEMPCE,IBZ,IBIFN,IBDA,IBVALM,Z,RSTA
D FULL^VALM1
I '$D(^TMP($J,"IBCEMCL",3)) D G TOGGLEX
. W !!?5,"There are no messages to select." D PAUSE^VALM1
. Q
S DIR(0)="LO^1:"_+$O(^TMP($J,"IBCEMCL",3,""),-1)
S DIR("A")="Select EDI Status Messages"
W ! D ^DIR K DIR
I $D(DIRUT) G TOGGLEX
M IBCEMLST=Y
F IBCEMSUB=0:1 Q:'$D(IBCEMLST(IBCEMSUB)) F IBCEMPCE=1:1 S IBSEL=$P(IBCEMLST(IBCEMSUB),",",IBCEMPCE) Q:'IBSEL D
. S IBZ=$G(^TMP($J,"IBCEMCL",3,IBSEL))
. S IBIFN=+IBZ,IBDA=+$P(IBZ,U,2),IBVALM=+$P(IBZ,U,4)
. I 'IBIFN Q
. I 'IBDA Q
. I 'IBVALM Q
. I '$D(^TMP($J,"IBCEMCL",2,IBVALM,0)) Q
. D MARK^IBCEMCL(IBDA,IBIFN,IBVALM,IBSEL,.Z)
. I Z'="" S RSTA(Z)=$G(RSTA(Z))+1
. Q
;
I $G(RSTA("L")) D ; display results only if some could not be selected
. W !!?8,"Number of messages selected: ",+$G(RSTA("S"))
. W !?5,"Number of messages de-selected: ",+$G(RSTA("D"))
. W !?2,"Number of messages that could not"
. W !?4,"be selected because other users"
. W !?12,"have them locked in CSA: ",+$G(RSTA("L"))
. D PAUSE^VALM1
. Q
TOGGLEX ;
S VALMBCK="R"
Q
;
INSLIST(INS) ; lister for DIC call. INS is ien to file 36.
; IB*2.0*547 - increase EDI#'s to 6 characters each
NEW AD,L1,CITY,ST,EDI,PROF,INST,PYRID
S AD=$G(^DIC(36,INS,.11))
S L1=$P(AD,U,1),CITY=$P(AD,U,4),ST=$P(AD,U,5)
I ST S ST=$P($G(^DIC(5,ST,0)),U,2)
S CITY=$E(CITY,1,15)
I CITY'="",ST'="" S CITY=CITY_","
S CITY=CITY_$E(ST,1,2)
;
S EDI=$G(^DIC(36,INS,3))
S PROF=$P(EDI,U,2),INST=$P(EDI,U,4)
;S PYRID=$E(PROF,1,5)
S PYRID=$E(PROF,1,6)
I PROF'="",INST'="" S PYRID=PYRID_"/"
;S PYRID=PYRID_$E(INST,1,5)
S PYRID=PYRID_$E(INST,1,6)
;
W ?27,$E(L1,1,20) ; address line 1
W ?47," ",CITY ; city,state
W ?67," ",PYRID ; payer IDs
INSLISTX ;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEMCA 6905 printed Oct 16, 2024@18:11:29 Page 2
IBCEMCA ;ALB/ESG - Multiple CSA Message Management ;20-SEP-2005
+1 ;;2.0;INTEGRATED BILLING;**320,547**;21-MAR-1994;Build 119
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
SCREEN ; Change the message selection criteria
+1 NEW DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,EDI,IBDONE,IBPAYER,INST,PROF,RESET,X,Y
+2 SET VALMBCK="R"
SET RESET=0
+3 DO FULL^VALM1
+4 WRITE !
+5 SET DIR(0)="Y"
SET DIR("A")="Do you want to change the MCS selection criteria"
+6 SET DIR("B")="Yes"
DO ^DIR
KILL DIR
+7 ; get out; no list rebuild
IF 'Y
GOTO SCREENX
+8 ; kill selection area and rebuild below
KILL ^TMP($JOB,"IBCEMCA")
+9 ; recalculate totals in header area
KILL VALMHDR
+10 ; begin new list display at line 1
SET VALMBG=1
+11 ;
Q1 ; payer
+1 WRITE !!,"PAYER SELECTION:"
+2 SET IBPAYER=""
+3 SET DIR(0)="SA^A:All Payers;S:Selected Payers"
+4 SET DIR("A")="Include All Payers or Selected Payers? "
+5 SET DIR("B")="All"
+6 DO ^DIR
KILL DIR
+7 ; kill scratch and rebuild list
IF $DATA(DIROUT)!$DATA(DIRUT)
SET RESET=1
GOTO QX
+8 IF Y="A"
KILL ^TMP($JOB,"IBCEMCA","INS")
GOTO Q2
+9 WRITE !
+10 SET DIR(0)="Y"
+11 SET DIR("A")=" Include all payers with the same electronic Payer ID"
+12 SET DIR("B")="Yes"
+13 DO ^DIR
KILL DIR
+14 ; kill scratch and rebuild the list
IF $DATA(DIROUT)
SET RESET=1
GOTO QX
+15 IF $DATA(DIRUT)
GOTO Q1
+16 SET IBPAYER=Y
+17 WRITE !
+18 ;
+19 SET IBDONE=0
+20 FOR
Begin DoDot:1
+21 SET DIC=36
SET DIC(0)="AEMQ"
SET DIC("A")=" Select Insurance Company: "
+22 IF $ORDER(^TMP($JOB,"IBCEMCA","INS",1,""))
SET DIC("A")=" Select Another Insurance Company: "
+23 SET DIC("W")="D INSLIST^IBCEMCA(Y)"
+24 ; lookup
DO ^DIC
KILL DIC
+25 ; user entered ^^
IF X="^^"
SET IBDONE=2
QUIT
+26 ; user is done
IF +Y'>0
SET IBDONE=1
QUIT
+27 SET ^TMP($JOB,"IBCEMCA","INS",1,+Y)=$PIECE(Y,U,2)
+28 IF 'IBPAYER
QUIT
+29 SET EDI=$$UP^XLFSTR($GET(^DIC(36,+Y,3)))
+30 SET PROF=$PIECE(EDI,U,2)
+31 SET INST=$PIECE(EDI,U,4)
+32 IF PROF'=""
IF PROF'["PRNT"
SET ^TMP($JOB,"IBCEMCA","INS",2,PROF,+Y)=""
+33 IF INST'=""
IF INST'["PRNT"
SET ^TMP($JOB,"IBCEMCA","INS",2,INST,+Y)=""
+34 QUIT
End DoDot:1
if IBDONE
QUIT
+35 ;
+36 ;kill scratch and rebuild the list
IF IBDONE=2
SET RESET=1
GOTO QX
+37 ;
+38 IF '$ORDER(^TMP($JOB,"IBCEMCA","INS",1,""))
Begin DoDot:1
+39 WRITE *7,!!?3,"No payers have been selected. Please try again."
+40 QUIT
End DoDot:1
GOTO Q1
+41 ;
Q2 ; division
+1 WRITE !!,"DIVISION SELECTION:"
+2 SET DIR(0)="SA^A:All Divisions;S:Selected Divisions"
+3 SET DIR("A")="Include All Divisions or Selected Divisions? "
+4 SET DIR("B")="All"
+5 DO ^DIR
KILL DIR
+6 ; kill scratch and rebuild list
IF $DATA(DIROUT)
SET RESET=1
GOTO QX
+7 IF $DATA(DIRUT)
GOTO Q1
+8 IF Y="A"
KILL ^TMP($JOB,"IBCEMCA","DIV")
GOTO Q3
+9 ;
+10 WRITE !
+11 SET IBDONE=0
+12 FOR
Begin DoDot:1
+13 SET DIC=40.8
SET DIC(0)="AEMQ"
SET DIC("A")=" Select Division: "
+14 IF $ORDER(^TMP($JOB,"IBCEMCA","DIV",""))
SET DIC("A")=" Select Another Division: "
+15 ; lookup
DO ^DIC
KILL DIC
+16 ; user entered ^^
IF X="^^"
SET IBDONE=2
QUIT
+17 ; user is done
IF +Y'>0
SET IBDONE=1
QUIT
+18 SET ^TMP($JOB,"IBCEMCA","DIV",+Y)=$PIECE(Y,U,2)
+19 QUIT
End DoDot:1
if IBDONE
QUIT
+20 ;
+21 ;kill scratch and rebuild the list
IF IBDONE=2
SET RESET=1
GOTO QX
+22 ;
+23 IF '$ORDER(^TMP($JOB,"IBCEMCA","DIV",""))
Begin DoDot:1
+24 WRITE *7,!!?3,"No divisions have been selected. Please try again."
+25 QUIT
End DoDot:1
GOTO Q2
+26 ;
Q3 ; message text
+1 WRITE !!,"ERROR MESSAGE TEXT SELECTION:"
+2 SET DIR(0)="SA^A:All Error Message Text;S:Select Error Message Text"
+3 SET DIR("A")="Include All Error Message Text or Select Error Message Text? "
+4 SET DIR("B")="All"
+5 DO ^DIR
KILL DIR
+6 ; kill scratch and rebuild list
IF $DATA(DIROUT)
SET RESET=1
GOTO QX
+7 IF $DATA(DIRUT)
GOTO Q2
+8 IF Y="A"
KILL ^TMP($JOB,"IBCEMCA","TEXT")
GOTO Q4
+9 ;
+10 WRITE !
+11 SET IBDONE=0
+12 FOR
Begin DoDot:1
+13 SET DIR(0)="FAOU"
+14 SET DIR("A")=" Text String: "
+15 IF $ORDER(^TMP($JOB,"IBCEMCA","TEXT",""))'=""
SET DIR("A")=" Another Text String: "
+16 ; user response
DO ^DIR
KILL DIR
+17 ; user entered ^^
IF $DATA(DIROUT)
SET IBDONE=2
QUIT
+18 ; leading up-arrow or time-out
IF $DATA(DIRUT)
SET IBDONE=1
QUIT
+19 ; null response
IF Y=""
SET IBDONE=1
QUIT
+20 SET ^TMP($JOB,"IBCEMCA","TEXT",Y)=""
+21 QUIT
End DoDot:1
if IBDONE
QUIT
+22 ;
+23 ;kill scratch and rebuild the list
IF IBDONE=2
SET RESET=1
GOTO QX
+24 ;
+25 IF $ORDER(^TMP($JOB,"IBCEMCA","TEXT",""))=""
Begin DoDot:1
+26 WRITE *7,!!?3,"No text has been selected. Please try again."
+27 QUIT
End DoDot:1
GOTO Q3
+28 ;
Q4 ; date range for when message received
+1 WRITE !!,"DATE MESSAGE RECEIVED SELECTION:"
+2 SET DIR(0)="SA^A:All Dates;S:Select Date Range"
+3 SET DIR("A")="Include All Dates or Select a Date Range? "
+4 SET DIR("B")="All"
+5 DO ^DIR
KILL DIR
+6 ; kill scratch and rebuild list
IF $DATA(DIROUT)
SET RESET=1
GOTO QX
+7 IF $DATA(DIRUT)
GOTO Q3
+8 IF Y="A"
KILL ^TMP($JOB,"IBCEMCA","DATE")
GOTO QX
+9 ;
Q4A ; beginning date
+1 WRITE !
+2 SET DIR(0)="DAO^:"_DT_":AEX"
SET DIR("A")=" Enter the beginning date: "
+3 DO ^DIR
KILL DIR
+4 ; kill scratch and rebuild list
IF $DATA(DIROUT)
SET RESET=1
GOTO QX
+5 IF $DATA(DIRUT)!'Y
GOTO Q4
+6 SET $PIECE(^TMP($JOB,"IBCEMCA","DATE"),U,1)=Y
+7 ;
Q4B ; ending date
+1 WRITE !
+2 SET DIR(0)="DAO^"_Y_":"_DT_":AEX"
SET DIR("A")=" Enter the ending date: "
+3 DO ^DIR
KILL DIR
+4 ; kill scratch and rebuild list
IF $DATA(DIROUT)
SET RESET=1
GOTO QX
+5 IF $DATA(DIRUT)!'Y
GOTO Q4A
+6 SET $PIECE(^TMP($JOB,"IBCEMCA","DATE"),U,2)=Y
+7 ;
QX ; end of questions, rebuild the list with user supplied selections
+1 IF RESET
KILL ^TMP($JOB,"IBCEMCA")
+2 DO INIT^IBCEMCL
+3 ;
SCREENX ;
+1 QUIT
+2 ;
TOGGLE ; Select/De-select entries in the list
+1 NEW IBSEL,DIR,X,Y,DIRUT,DIROUT,DTOUT,DUOUT,IBCEMLST,IBCEMSUB,IBCEMPCE,IBZ,IBIFN,IBDA,IBVALM,Z,RSTA
+2 DO FULL^VALM1
+3 IF '$DATA(^TMP($JOB,"IBCEMCL",3))
Begin DoDot:1
+4 WRITE !!?5,"There are no messages to select."
DO PAUSE^VALM1
+5 QUIT
End DoDot:1
GOTO TOGGLEX
+6 SET DIR(0)="LO^1:"_+$ORDER(^TMP($JOB,"IBCEMCL",3,""),-1)
+7 SET DIR("A")="Select EDI Status Messages"
+8 WRITE !
DO ^DIR
KILL DIR
+9 IF $DATA(DIRUT)
GOTO TOGGLEX
+10 MERGE IBCEMLST=Y
+11 FOR IBCEMSUB=0:1
if '$DATA(IBCEMLST(IBCEMSUB))
QUIT
FOR IBCEMPCE=1:1
SET IBSEL=$PIECE(IBCEMLST(IBCEMSUB),",",IBCEMPCE)
if 'IBSEL
QUIT
Begin DoDot:1
+12 SET IBZ=$GET(^TMP($JOB,"IBCEMCL",3,IBSEL))
+13 SET IBIFN=+IBZ
SET IBDA=+$PIECE(IBZ,U,2)
SET IBVALM=+$PIECE(IBZ,U,4)
+14 IF 'IBIFN
QUIT
+15 IF 'IBDA
QUIT
+16 IF 'IBVALM
QUIT
+17 IF '$DATA(^TMP($JOB,"IBCEMCL",2,IBVALM,0))
QUIT
+18 DO MARK^IBCEMCL(IBDA,IBIFN,IBVALM,IBSEL,.Z)
+19 IF Z'=""
SET RSTA(Z)=$GET(RSTA(Z))+1
+20 QUIT
End DoDot:1
+21 ;
+22 ; display results only if some could not be selected
IF $GET(RSTA("L"))
Begin DoDot:1
+23 WRITE !!?8,"Number of messages selected: ",+$GET(RSTA("S"))
+24 WRITE !?5,"Number of messages de-selected: ",+$GET(RSTA("D"))
+25 WRITE !?2,"Number of messages that could not"
+26 WRITE !?4,"be selected because other users"
+27 WRITE !?12,"have them locked in CSA: ",+$GET(RSTA("L"))
+28 DO PAUSE^VALM1
+29 QUIT
End DoDot:1
TOGGLEX ;
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
INSLIST(INS) ; lister for DIC call. INS is ien to file 36.
+1 ; IB*2.0*547 - increase EDI#'s to 6 characters each
+2 NEW AD,L1,CITY,ST,EDI,PROF,INST,PYRID
+3 SET AD=$GET(^DIC(36,INS,.11))
+4 SET L1=$PIECE(AD,U,1)
SET CITY=$PIECE(AD,U,4)
SET ST=$PIECE(AD,U,5)
+5 IF ST
SET ST=$PIECE($GET(^DIC(5,ST,0)),U,2)
+6 SET CITY=$EXTRACT(CITY,1,15)
+7 IF CITY'=""
IF ST'=""
SET CITY=CITY_","
+8 SET CITY=CITY_$EXTRACT(ST,1,2)
+9 ;
+10 SET EDI=$GET(^DIC(36,INS,3))
+11 SET PROF=$PIECE(EDI,U,2)
SET INST=$PIECE(EDI,U,4)
+12 ;S PYRID=$E(PROF,1,5)
+13 SET PYRID=$EXTRACT(PROF,1,6)
+14 IF PROF'=""
IF INST'=""
SET PYRID=PYRID_"/"
+15 ;S PYRID=PYRID_$E(INST,1,5)
+16 SET PYRID=PYRID_$EXTRACT(INST,1,6)
+17 ;
+18 ; address line 1
WRITE ?27,$EXTRACT(L1,1,20)
+19 ; city,state
WRITE ?47," ",CITY
+20 ; payer IDs
WRITE ?67," ",PYRID
INSLISTX ;
+1 QUIT
+2 ;
