IBACCWLAIREAS ;EDE/TPF - ACC (Automated Community Care) Encounters - Action Item Reassignment; 12-SEP-2023
;;2.0;INTEGRATED BILLING;**770**;21-MAR-2024;Build 119
;;Per VA Directive 6402, this routine should not be modified.
Q
;
;D REASSIGN^IBACCWLRA
;CALLED BY ACTION PROTOCOLS:
;IBACC WL IBACCCOMMON REASSIGN ENCOUNTER
REASSIGN ;EP - REASSIGN CLAIM TO OTHER USER/GROUP. CREATES NEW ENTRY IN MULTIPLE #4 PREVIOUS ACTIVITY
N ACTION,ACTIONCODE,ACTION101,ACTCODEIEN,ACTGRPIEN,ACTIVITYCODE,ACTCODES,ACTCODENUM,ALLOWEDGRPS,ASSIGNTOGRPIEN
N BATCHITEM,BATCHCOMMENT,BATCHGROUP,IBDAIEN,ESCAPE,LASTONEPUBLISHED
N DUOUT,DIROUT,DTOUT
;
S VALMSG="* = In progress| ! = Patient not in VistA |??=Help"
;
S ACTION=$G(Y(1))
S ACTIONCODE=$$GET1^DIQ(101,$P(Y(1),U,2)_",",44,"E") ;TPF;IB*2*770v22;EBILL-5021
S ACTION101=$P(ACTION,U,2)
;
I '$G(IBDA) N IBDA D SEL(.IBDA,"L")
;
I '$D(IBDA) S VALMBCK="R" Q
;
Q:$G(IBDA(IBDA))["----------------------"
;
D FULL^VALM1 ;TPF;IB*2*770v26;EBILL-5128
;CHECK SELECTED RECORDS TO SEE IF THEY HAVE BEEN REASSIGNED. IF IN THE "UNAVAILABLE STATUS' REMOVE FROM BATCH
D AVAILABLECHK^IBACCWLUTIL1(.IBDA)
;
;BEGIN TPF;IB*2*770vPURPLE;EBILL-5466
I ACTIONCODE="NB" D Q:'$D(IBDA) ;BEGIN TPF;IB*2*770v36;EBILL-5754
.D NBSCREEN^IBACCWLUTIL1(.IBDA)
.S VALMBCK="R"
.Q:'$D(IBDA)
.;END TPF;IB*2*770vPURPLE;EBILL-5466
;
I '$D(IBDA) S VALMBCK="R" Q
;I IBDA=1,('$D(IBDA(IBDA))) S VALMBCK="R" Q ;TPF;IB*2*770v20;BEGIN EBILL-4055 MOD RELEVANT TO THE RU ACTION WITH ACTIVITY CODE 508 FROM EE ONLY
I IBDA("TOTAL")=1,('$D(IBDA(IBDA))) S VALMBCK="R" Q ;TPF;IB*2*770v22;BEGIN EBILL-4920 CORRECTION TO ERROR RESOLUTION FOUND DURING EBILL-4055
;
S ACTCODENUM=0
S ACTCODES=0
F S ACTCODES=$O(^IBA(364.92,"AC",ACTIONCODE,USERGROUP,ACTCODES)) Q:ACTCODES="" D ;GET ACTIVITY CODES ALLOWED BY THIS ACTION AND USER GROUP
.S ACTCODENUM=$G(ACTCODENUM)+1
.;GET IEN FOR USE IN SCREEN
.S ACTCODEIEN=$O(^IBA(364.92,"B",ACTCODES,0))
.Q:$P($G(^IBA(364.92,ACTCODEIEN,0)),U,4) ;SKIP INACTIVE ACTIVITY CODES
.S ACTCODES(ACTCODEIEN)=ACTCODES
;
I ACTCODENUM<0!(ACTCODENUM=0) D Q
.W !!,"THERE ARE NO ACTIVITY CODES SET UP FOR ACTION: "_ACTIONCODE_" AND USER GROUP: "_USERGROUP
.W !,"PLEASE REPORT TO YOUR IB BILLING SUPERVISOR."
.S VALMBCK="R"
.N DIR
.S DIR(0)="E"
.D ^DIR
;
I ACTCODENUM=1 D ;TPF;IB*2*770v37;EBILL-5789
.W !!,"THERE IS ONLY ONE ACTIVITY CODE SET UP FOR"
.W !,"ACTION: "_ACTIONCODE
.W !,"USER GROUP: "_USERGROUP
.S ACTCODEIEN=$O(ACTCODES(0))
.W !,"ACTIVITY CODE: ",$TR($P(^IBA(364.92,ACTCODEIEN,0),U,1,2),U," ")
.W !,"SO IT WILL BE USED TO UPDATE THE WORKLIST."
.;TPF;IB*2*770v37;EBILL-5789
;
N DIC
I ACTCODENUM>1 D I Y<0 S VALMBCK="R" Q
.S DIC("S")="I $D(ACTCODES(Y))"
.S DIC(0)="AEMQ"
.S DIC="^IBA(364.92,"
.D ^DIC
.Q:Y<0
.S ACTCODEIEN=+Y
;
;BEGIN TPF;IB*2*770v34;EBILL-5715
I $$GET1^DIQ(364.92,ACTCODEIEN_",",.01)=506 D Q:'$D(IBDA) ;BEGIN TPF;IB*2*770v36;EBILL-5754
.D IPSCREEN^IBACCWLUTIL1(.IBDA) ;INPATIENT SCREEN
.S VALMBCK="R"
.Q:'$D(IBDA)
;END TPF;IB*2*770v34;EBILL-5715
;
;BEGIN TPF;IB*2*770v37;EBILL-5795 CONFIRMATION PROMPT
N DIR,DUOUT,DIROUT,DTOUT,X,Y
I (U_23_U_26_U_27_U_508_U)'[(U_$$GET1^DIQ(364.92,ACTCODEIEN_",",.01)_U) D I $D(DUOUT)!$D(DIROUT)!$D(DTOUT)!(Y=0) S VALMBCK="R" Q
.W !
.S DIR(0)="YO"
.S DIR("A")="Are you sure you wish to continue"
.S DIR("B")="Y"
.D ^DIR
;END TPF;IB*2*770v37;EBILL-5795
;
S LASTONEPUBLISHED=0
S ESCAPE=0
;
N TMPIBDA ;TPF;IB*2*770v34;EBILL-5708
S IBDAIEN=""
F BATCHITEM=1:1 S IBDAIEN=$O(IBDA(IBDAIEN)) Q:'IBDAIEN!($G(ESCAPE)) D
.Q:$G(IBDA(IBDAIEN))["----------------------"
.;
.;TPF;IB*2*770v20;BEGIN EBILL-4055
.I (U_23_U_26_U_27_U_508_U)[(U_$$GET1^DIQ(364.92,ACTCODEIEN_",",.01)_U) D ;TPF;IB*2*770v27;EBILL-5346
..M TMPIBDA=IBDA ;TPF;IB*2*770v34;EBILL-5708
..D RESUBMITLOOP^IBACCWLAIBILL(IBDAIEN,BATCHITEM,.BATCHCOMMENT,.SUCCESS,.LASTONEPUBLISHED) ;TPF;IB*2*770v34;EBILL-5708
..I '$D(IBDA) M IBDA=TMPIBDA ;TPF;IB*2*770v34;EBILL-5708
.E D REASSIGNLOOP(IBDAIEN,ACTCODEIEN,ESCAPE,BATCHITEM,.BATCHCOMMENT,.BATCHGROUP,.LASTONEPUBLISHED)
;
;TPF;IB*2*770v38;EBILL-5485
;IF THE WL IS A PARENT OR DISPLAYS RECORDS WE RELOAD
I $G(IBPARENT) K @VALMAR S:VALMBG=VALMLST VALMBG=VALMBG-VALM("LINES") D PULLLIST^IBACCWL1(.IBDAYSMAX,.IBBILLER,.IBDIV,.IBSORT,0) S VALMBCK="R" Q
E S IBICAMEFROMEE=1 S VALMBCK="R" Q ;TPF;IB*2*770v38;EBILL-5485
;
S VALMBCK="R"
;
Q
;
REASSIGNLOOP(IBDAIEN,ACTCODEIEN,ESCAPE,BATCHITEM,BATCHCOMMENT,BATCHGROUP,LASTONEPUBLISHED) ;LOOP THROUGH SELECTIONS
;
N ADDFDA,ADDIENS,ADDERR,CURASSIGGRP,DEFSTATUS,DFN,DIC,EDITFDA,EDITIENS,EDITERR,FROMSTATUS
N IBBILL,IBIFN,IBENCIFN,NOW,PREVACTIVITY,PUBSUCCESS,PREVACTIVITY,REP,X,Y
;
;IBPARENT=0 SHOWS IT IS A "CHILD" SCREEN!
I $G(IBPARENT)=0 D ;TPF;IB*2*770v38;EBILL-5485
.S IBENCIFN=$G(@VALMAR@("IEN3649",1))
.S IBIFN=$G(@VALMAR@("IEN399",1))
E D
.S IBIFN=$G(@VALMAR@(IBDAIEN,"IEN399",1))
.S IBENCIFN=$G(@VALMAR@(IBDAIEN,"IEN3649",1))
;
S CURASSIGGRP=$$GET1^DIQ(364.9,IBENCIFN_",",3.01)
S FROMSTATUS=$$GET1^DIQ(364.9,IBENCIFN_",",.16)
;
I IBENCIFN S DFN=$P($G(^IBA(364.9,IBENCIFN,2)),U)
E S DFN="NOT FOUND"
;
D FULL^VALM1 ;TPF;IB*2*770v32;EBILL-5503
;
W !!,"PROCESSING RECORD(S): " N CNT,IEN S IEN=0 F CNT=1:1 S IEN=$O(IBDA(IEN)) Q:'IEN W $S(CNT'=1:",",1:"")_IEN
;
I IBIFN'="" D
.S DFN=$P($G(^DGCR(399,+$G(IBIFN),0)),U,2)
.S IBBILL=$P($G(^DGCR(399,IBIFN,0)),U)
E D
.Q:$G(ACTIONCODE)="NB" ;TPF;IB*2*770v37;EBILL-5755
.W !!,"This encounter does not have a K#."
;
I $G(IBBILL)'="" D
.W !,"ACC CLAIM/BILL "_IBBILL_" SELECTED" H 2
E D
.Q:$G(ACTIONCODE)="NB" ;TPF;IB*2*770v37;EBILL-5755
.W !,"X12 ENCOUNTER NUMBER: ",$P($G(^IBA(364.9,IBENCIFN,0)),U,15),!
;
D FULL^VALM1
;
S ACTGRPIEN=$O(^IBA(364.92,ACTCODEIEN,5,"B",USERGROUP,0)) ;IEN OF ASSIGNING GROUP
S ASSIGNGRP=USERGROUP
;
S:$G(ACTGRPIEN)'="" ASSIGNTOGRPIEN=$O(^IBA(364.92,ACTCODEIEN,5,ACTGRPIEN,5,0))
S:$G(ASSIGNTOGRPIEN)'="" ASSIGNTOGRP=$G(^IBA(364.92,ACTCODEIEN,5,ACTGRPIEN,5,ASSIGNTOGRPIEN,0))
;
S DEFSTATUS=$$GET1^DIQ(364.92,ACTCODEIEN,.03,"")
;
I DEFSTATUS'="CLOSED",(ASSIGNTOGRPIEN="")!($P($G(^IBA(364.92,ACTCODEIEN,5,ACTGRPIEN,5,0)),U,3)>1),(BATCHITEM=1) D I ASSIGNTOGRP=U S VALMBCK="R" Q ;TPF;IB*2*7077V6;EBILL=????;10/15/2024
.W !!,"YOU CAN REASSIGN THIS ENCOUNTER TO THE FOLLOWING GROUPS:"
.N CODES,DA,DIR,ALLOWEDGRPS,CODESLIST
.;S CODES=$P($G(^DD(364.925,.01,0)),U,3)
.D FIELD^DID(364.925,.01,"","POINTER","CODESLIST") ;MJL fix
.S CODES=$G(CODESLIST("POINTER")) ;MJL fix
.S ALLOWEDGRPS=$P(CODES,";HIMS:HEALTH INFORMATION MANAGEMENT",1)_$P(CODES,";HIMS:HEALTH INFORMATION MANAGEMENT",2)
.S DIR("S")="I Y'=ASSIGNGRP" ;!(Y'=""HIMS"")" ;TPF;IB*2*7077V6;EBILL=????;10/15/2024
.S DIR(0)="S^"_ALLOWEDGRPS
.D ^DIR
.S (BATCHGROUP,ASSIGNTOGRP)=Y
;
I $G(BATCHITEM)>1,$D(BATCHGROUP) S ASSIGNTOGRP=BATCHGROUP
;
;UPDATE PREVIOUS ACTIVITY
S ADDIENS="+1,"_IBENCIFN_","
S ADDFDA(364.94,ADDIENS,.01)="NOW"
S ADDFDA(364.94,ADDIENS,.02)="`"_$G(DUZ)
S ADDFDA(364.94,ADDIENS,.03)="`"_$G(ACTCODEIEN)
S ADDFDA(364.94,ADDIENS,.04)=$G(ASSIGNGRP)
S ADDFDA(364.94,ADDIENS,.05)=$G(ASSIGNTOGRP)
;
D UPDATE^DIE("ES","ADDFDA","ADDIENS","ADDERR")
;
I $D(ADDERR) D Q ;TPF;IB*2*770v11;EBILL-4523 ;CHANGE TO SOP FOR ERROR CHECKS IN WL
.W !!,"Problem adding Previous Activity Multiple for Encounter. Report to eBilling" S VALMBCK="R"
.W !,$G(ADDERR("DIERR",1,"TEXT",1))
.N DIR,DIRUT,DUOUT,DTOUT
.D PAUSE^VALM1
;
S DA=ADDIENS(1)
S DA(1)=IBENCIFN
D EDITPREVACT(.DA,.DEFSTATUS,.ASSIGNTOGRP,.ESCAPE,BATCHITEM,.BATCHCOMMENT) ;EDIT PREVIOUS ACTIVITY
;
D FULL^VALM1 ;TPF;IB*2*770v32;EBILL-5503
;AT THIS POINT THE UPDATE AND REASSIGNMENT IS SUCCESSFUL SO LETS UPDATE CURRENT SCREEN
;AND MOVE THE ENTRY TO OTHER SCREENS IF THEY ARE ACTIVE
;
I $G(IBPARENT)=0 D EEPUBLISH^IBACCWLUTIL1(IBDAIEN,.IBFROMVALMDDF,"",.LASTONEPUBLISHED) S VALMBCK="R" Q ;TPF;IB*2*770v38;EBILL-5485,5721
;
;UPDATE THIS USER'S SCREEN LIST
D:$D(VALMDDF("ASSIGNEDGRP")) FLDTEXT^VALM10(IBDAIEN,"ASSIGNEDGRP",$G(ASSIGNTOGRP))
D:$D(VALMDDF("INDICATOR")) FLDTEXT^VALM10(IBDAIEN,"INDICATOR","# ") ;# MEANS ENCOUNTER HAS BEEN REASSIGNED OR SUCCESSFULLY RESUBMITTED AND UNAVAILABLE IN THE CURRENT WORKLIST
I $D(VALMDDF("PREVACT")) S:$G(ACTCODEIEN) PREVACTIVITY=$P($G(^IBA(364.92,ACTCODEIEN,0)),U)_" "_$E($P($G(^IBA(364.92,ACTCODEIEN,0)),U,2),1,$P(VALMDDF("PREVACT"),U,3))
D:$D(VALMDDF("PREVACT")) FLDTEXT^VALM10(IBDAIEN,"PREVACT",$G(PREVACTIVITY))
;
I $G(ASSIGNTOGRP)'="" D
.S @VALMAR@(IBDAIEN,"UNAVAILABLE")="RECORD HAS BEEN REASSIGNED. ON YOUR NEXT LOG IN YOU WILL NOT SEE THIS ENTRY."
.D:$D(VALMDDF("DATEASSNED")) FLDTEXT^VALM10(IBDAIEN,"DATEASSNED",$$FMTE^XLFDT($$GET1^DIQ(364.9,IBENCIFN_",",3.03,"I"),"2ZD"))
;
D:$G(PUBLISHINGON)&($G(ASSIGNTOGRP)'="") PUBLISH^IBACCWLUTIL(ASSIGNGRP,IBENCIFN,IBDAIEN,ASSIGNTOGRP,.VALMDDF,.PUBSUCCESS,IBDAIEN,.LASTONEPUBLISHED) ;UPDATE OTHER USERS IN ASSIGNED TO GROUP
;
S VALMBCK="R"
;
Q
;
EDITPREVACT(DA,DEFSTATUS,ASSIGNTOGRP,ESCAPE,BATCHITEM,BATCHCOMMENT) ;EP- EDIT PREVIOUS ACTIVITY
N DIE,ERROR,PREVACTIENS,PREVACTRET,RETURN
;
S ESCAPE=0
;
;CHANGE STATUS BASED ON ACTIVITY CODE
I $G(DEFSTATUS)="" D EDITSTATUS^IBACCWLUTIL(DA(1),.DEFSTATUS)
E D UPDSTATUS^IBACCWLUTIL(DA(1),.DEFSTATUS)
;
I DEFSTATUS'="CLOSED" D ;IF STATUS CLOSED DO NOT ASK FOR A GROUP TO REASSIGN TO
.I $G(ASSIGNTOGRP)="" D EDITAS2GRP^IBACCWLUTIL(DA(1),.ASSIGNTOGRP)
.E D UPDAS2GRP^IBACCWLUTIL(DA(1),.ASSIGNTOGRP,1) ;TPF;IB*2*770v23;EBILL-5036
;
;TPF;IB*2*770v32;EBILL-5503
I $G(ACTCODENUM)'=1,($G(ACTIONCODE)'="NB") D ;TPF;IB*2*770v37;EBILL-5789
.N DIR
.S DIR(0)="E"
.S DIR("A")="Type <Enter> to continue" ; EBILL-5859;WCJ;v39
.D ^DIR
;
;
S PREVACTIENS=$$IENS^DILF(.DA)
I BATCHITEM=1 D Q
.W !!,"Enter a comment so processing can fully be documented and the Reassignment"
.W !,"Group knows what has already been done or might be requested to do."
.W !,"This comment will be applied to "_$S($G(IBDA("TOTAL"))>1:"the entire batch.",1:"this encounter.") ;TPF;IB*2*770v38;EBILL-5825
.W !
.;
.S DIE="^IBA(364.9,"_DA(1)_",4,"
.S DR=""
.S DR=DR_"10"
.D ^DIE
.D GETS^DIQ(364.94,PREVACTIENS,"**","EIR","PREVACTRET","ERROR")
.M BATCHCOMMENT=PREVACTRET(364.94,PREVACTIENS,"PREVIOUS ACTIVITY COMMENTS")
.K BATCHCOMMENT("E")
.K BATCHCOMMENT("I")
;
I BATCHITEM>1,$D(BATCHCOMMENT) D Q ;THIS MEANS WE HAVE ALREADY CREATED A COMMENT IF BATCHITEM=1
.K WPERR D EDITPREVACT^IBACCWLUTIL(PREVACTIENS,.BATCHCOMMENT,.WPERR)
.I $D(WPERR) D ;TPF;IB*2*770v11;EBILL-4523 ;CHANGE TO SOP FOR ERROR CHECKS IN WL
..W !!,"Problem adding comment to Encounter. Report to eBilling"
..S VALMBCK="R"
..W !,$G(WPERR("DIERR",1,"TEXT",1))
..N DIR,DIRUT,DUOUT,DTOUT
..D PAUSE^VALM1
;
S VALMBCK="R"
Q
;
SEL(IBDA,OPTION) ;EP -
K IBDA,VALMY
D FULL^VALM1
D EN^VALM2($G(XQORNOD(0)),$S($G(OPTION)'="":OPTION,1:"S"))
Q:'$D(VALMY)
;
S IBDA("TOTAL")=0
S IBDA=0
F S IBDA=$O(VALMY(IBDA)) Q:'IBDA D
.S IBDA(IBDA)=$G(@VALMAR@(+IBDA,0))
.S IBDA("TOTAL")=IBDA("TOTAL")+1
S IBDA=$O(IBDA("")) ;ONLY IF ONE SELECTION. NEED A FOR LOOP FOR MULTIPLES
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBACCWLAIREAS 11400 printed May 25, 2026@12:09:50 Page 2
IBACCWLAIREAS ;EDE/TPF - ACC (Automated Community Care) Encounters - Action Item Reassignment; 12-SEP-2023
+1 ;;2.0;INTEGRATED BILLING;**770**;21-MAR-2024;Build 119
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;D REASSIGN^IBACCWLRA
+6 ;CALLED BY ACTION PROTOCOLS:
+7 ;IBACC WL IBACCCOMMON REASSIGN ENCOUNTER
REASSIGN ;EP - REASSIGN CLAIM TO OTHER USER/GROUP. CREATES NEW ENTRY IN MULTIPLE #4 PREVIOUS ACTIVITY
+1 NEW ACTION,ACTIONCODE,ACTION101,ACTCODEIEN,ACTGRPIEN,ACTIVITYCODE,ACTCODES,ACTCODENUM,ALLOWEDGRPS,ASSIGNTOGRPIEN
+2 NEW BATCHITEM,BATCHCOMMENT,BATCHGROUP,IBDAIEN,ESCAPE,LASTONEPUBLISHED
+3 NEW DUOUT,DIROUT,DTOUT
+4 ;
+5 SET VALMSG="* = In progress| ! = Patient not in VistA |??=Help"
+6 ;
+7 SET ACTION=$GET(Y(1))
+8 ;TPF;IB*2*770v22;EBILL-5021
SET ACTIONCODE=$$GET1^DIQ(101,$PIECE(Y(1),U,2)_",",44,"E")
+9 SET ACTION101=$PIECE(ACTION,U,2)
+10 ;
+11 IF '$GET(IBDA)
NEW IBDA
DO SEL(.IBDA,"L")
+12 ;
+13 IF '$DATA(IBDA)
SET VALMBCK="R"
QUIT
+14 ;
+15 if $GET(IBDA(IBDA))["----------------------"
QUIT
+16 ;
+17 ;TPF;IB*2*770v26;EBILL-5128
DO FULL^VALM1
+18 ;CHECK SELECTED RECORDS TO SEE IF THEY HAVE BEEN REASSIGNED. IF IN THE "UNAVAILABLE STATUS' REMOVE FROM BATCH
+19 DO AVAILABLECHK^IBACCWLUTIL1(.IBDA)
+20 ;
+21 ;BEGIN TPF;IB*2*770vPURPLE;EBILL-5466
+22 ;BEGIN TPF;IB*2*770v36;EBILL-5754
IF ACTIONCODE="NB"
Begin DoDot:1
+23 DO NBSCREEN^IBACCWLUTIL1(.IBDA)
+24 SET VALMBCK="R"
+25 if '$DATA(IBDA)
QUIT
+26 ;END TPF;IB*2*770vPURPLE;EBILL-5466
End DoDot:1
if '$DATA(IBDA)
QUIT
+27 ;
+28 IF '$DATA(IBDA)
SET VALMBCK="R"
QUIT
+29 ;I IBDA=1,('$D(IBDA(IBDA))) S VALMBCK="R" Q ;TPF;IB*2*770v20;BEGIN EBILL-4055 MOD RELEVANT TO THE RU ACTION WITH ACTIVITY CODE 508 FROM EE ONLY
+30 ;TPF;IB*2*770v22;BEGIN EBILL-4920 CORRECTION TO ERROR RESOLUTION FOUND DURING EBILL-4055
IF IBDA("TOTAL")=1
IF ('$DATA(IBDA(IBDA)))
SET VALMBCK="R"
QUIT
+31 ;
+32 SET ACTCODENUM=0
+33 SET ACTCODES=0
+34 ;GET ACTIVITY CODES ALLOWED BY THIS ACTION AND USER GROUP
FOR
SET ACTCODES=$ORDER(^IBA(364.92,"AC",ACTIONCODE,USERGROUP,ACTCODES))
if ACTCODES=""
QUIT
Begin DoDot:1
+35 SET ACTCODENUM=$GET(ACTCODENUM)+1
+36 ;GET IEN FOR USE IN SCREEN
+37 SET ACTCODEIEN=$ORDER(^IBA(364.92,"B",ACTCODES,0))
+38 ;SKIP INACTIVE ACTIVITY CODES
if $PIECE($GET(^IBA(364.92,ACTCODEIEN,0)),U,4)
QUIT
+39 SET ACTCODES(ACTCODEIEN)=ACTCODES
End DoDot:1
+40 ;
+41 IF ACTCODENUM<0!(ACTCODENUM=0)
Begin DoDot:1
+42 WRITE !!,"THERE ARE NO ACTIVITY CODES SET UP FOR ACTION: "_ACTIONCODE_" AND USER GROUP: "_USERGROUP
+43 WRITE !,"PLEASE REPORT TO YOUR IB BILLING SUPERVISOR."
+44 SET VALMBCK="R"
+45 NEW DIR
+46 SET DIR(0)="E"
+47 DO ^DIR
End DoDot:1
QUIT
+48 ;
+49 ;TPF;IB*2*770v37;EBILL-5789
IF ACTCODENUM=1
Begin DoDot:1
+50 WRITE !!,"THERE IS ONLY ONE ACTIVITY CODE SET UP FOR"
+51 WRITE !,"ACTION: "_ACTIONCODE
+52 WRITE !,"USER GROUP: "_USERGROUP
+53 SET ACTCODEIEN=$ORDER(ACTCODES(0))
+54 WRITE !,"ACTIVITY CODE: ",$TRANSLATE($PIECE(^IBA(364.92,ACTCODEIEN,0),U,1,2),U," ")
+55 WRITE !,"SO IT WILL BE USED TO UPDATE THE WORKLIST."
+56 ;TPF;IB*2*770v37;EBILL-5789
End DoDot:1
+57 ;
+58 NEW DIC
+59 IF ACTCODENUM>1
Begin DoDot:1
+60 SET DIC("S")="I $D(ACTCODES(Y))"
+61 SET DIC(0)="AEMQ"
+62 SET DIC="^IBA(364.92,"
+63 DO ^DIC
+64 if Y<0
QUIT
+65 SET ACTCODEIEN=+Y
End DoDot:1
IF Y<0
SET VALMBCK="R"
QUIT
+66 ;
+67 ;BEGIN TPF;IB*2*770v34;EBILL-5715
+68 ;BEGIN TPF;IB*2*770v36;EBILL-5754
IF $$GET1^DIQ(364.92,ACTCODEIEN_",",.01)=506
Begin DoDot:1
+69 ;INPATIENT SCREEN
DO IPSCREEN^IBACCWLUTIL1(.IBDA)
+70 SET VALMBCK="R"
+71 if '$DATA(IBDA)
QUIT
End DoDot:1
if '$DATA(IBDA)
QUIT
+72 ;END TPF;IB*2*770v34;EBILL-5715
+73 ;
+74 ;BEGIN TPF;IB*2*770v37;EBILL-5795 CONFIRMATION PROMPT
+75 NEW DIR,DUOUT,DIROUT,DTOUT,X,Y
+76 IF (U_23_U_26_U_27_U_508_U)'[(U_$$GET1^DIQ(364.92,ACTCODEIEN_",",.01)_U)
Begin DoDot:1
+77 WRITE !
+78 SET DIR(0)="YO"
+79 SET DIR("A")="Are you sure you wish to continue"
+80 SET DIR("B")="Y"
+81 DO ^DIR
End DoDot:1
IF $DATA(DUOUT)!$DATA(DIROUT)!$DATA(DTOUT)!(Y=0)
SET VALMBCK="R"
QUIT
+82 ;END TPF;IB*2*770v37;EBILL-5795
+83 ;
+84 SET LASTONEPUBLISHED=0
+85 SET ESCAPE=0
+86 ;
+87 ;TPF;IB*2*770v34;EBILL-5708
NEW TMPIBDA
+88 SET IBDAIEN=""
+89 FOR BATCHITEM=1:1
SET IBDAIEN=$ORDER(IBDA(IBDAIEN))
if 'IBDAIEN!($GET(ESCAPE))
QUIT
Begin DoDot:1
+90 if $GET(IBDA(IBDAIEN))["----------------------"
QUIT
+91 ;
+92 ;TPF;IB*2*770v20;BEGIN EBILL-4055
+93 ;TPF;IB*2*770v27;EBILL-5346
IF (U_23_U_26_U_27_U_508_U)[(U_$$GET1^DIQ(364.92,ACTCODEIEN_",",.01)_U)
Begin DoDot:2
+94 ;TPF;IB*2*770v34;EBILL-5708
MERGE TMPIBDA=IBDA
+95 ;TPF;IB*2*770v34;EBILL-5708
DO RESUBMITLOOP^IBACCWLAIBILL(IBDAIEN,BATCHITEM,.BATCHCOMMENT,.SUCCESS,.LASTONEPUBLISHED)
+96 ;TPF;IB*2*770v34;EBILL-5708
IF '$DATA(IBDA)
MERGE IBDA=TMPIBDA
End DoDot:2
+97 IF '$TEST
DO REASSIGNLOOP(IBDAIEN,ACTCODEIEN,ESCAPE,BATCHITEM,.BATCHCOMMENT,.BATCHGROUP,.LASTONEPUBLISHED)
End DoDot:1
+98 ;
+99 ;TPF;IB*2*770v38;EBILL-5485
+100 ;IF THE WL IS A PARENT OR DISPLAYS RECORDS WE RELOAD
+101 IF $GET(IBPARENT)
KILL @VALMAR
if VALMBG=VALMLST
SET VALMBG=VALMBG-VALM("LINES")
DO PULLLIST^IBACCWL1(.IBDAYSMAX,.IBBILLER,.IBDIV,.IBSORT,0)
SET VALMBCK="R"
QUIT
+102 ;TPF;IB*2*770v38;EBILL-5485
IF '$TEST
SET IBICAMEFROMEE=1
SET VALMBCK="R"
QUIT
+103 ;
+104 SET VALMBCK="R"
+105 ;
+106 QUIT
+107 ;
REASSIGNLOOP(IBDAIEN,ACTCODEIEN,ESCAPE,BATCHITEM,BATCHCOMMENT,BATCHGROUP,LASTONEPUBLISHED) ;LOOP THROUGH SELECTIONS
+1 ;
+2 NEW ADDFDA,ADDIENS,ADDERR,CURASSIGGRP,DEFSTATUS,DFN,DIC,EDITFDA,EDITIENS,EDITERR,FROMSTATUS
+3 NEW IBBILL,IBIFN,IBENCIFN,NOW,PREVACTIVITY,PUBSUCCESS,PREVACTIVITY,REP,X,Y
+4 ;
+5 ;IBPARENT=0 SHOWS IT IS A "CHILD" SCREEN!
+6 ;TPF;IB*2*770v38;EBILL-5485
IF $GET(IBPARENT)=0
Begin DoDot:1
+7 SET IBENCIFN=$GET(@VALMAR@("IEN3649",1))
+8 SET IBIFN=$GET(@VALMAR@("IEN399",1))
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 SET IBIFN=$GET(@VALMAR@(IBDAIEN,"IEN399",1))
+11 SET IBENCIFN=$GET(@VALMAR@(IBDAIEN,"IEN3649",1))
End DoDot:1
+12 ;
+13 SET CURASSIGGRP=$$GET1^DIQ(364.9,IBENCIFN_",",3.01)
+14 SET FROMSTATUS=$$GET1^DIQ(364.9,IBENCIFN_",",.16)
+15 ;
+16 IF IBENCIFN
SET DFN=$PIECE($GET(^IBA(364.9,IBENCIFN,2)),U)
+17 IF '$TEST
SET DFN="NOT FOUND"
+18 ;
+19 ;TPF;IB*2*770v32;EBILL-5503
DO FULL^VALM1
+20 ;
+21 WRITE !!,"PROCESSING RECORD(S): "
NEW CNT,IEN
SET IEN=0
FOR CNT=1:1
SET IEN=$ORDER(IBDA(IEN))
if 'IEN
QUIT
WRITE $SELECT(CNT'=1:",",1:"")_IEN
+22 ;
+23 IF IBIFN'=""
Begin DoDot:1
+24 SET DFN=$PIECE($GET(^DGCR(399,+$GET(IBIFN),0)),U,2)
+25 SET IBBILL=$PIECE($GET(^DGCR(399,IBIFN,0)),U)
End DoDot:1
+26 IF '$TEST
Begin DoDot:1
+27 ;TPF;IB*2*770v37;EBILL-5755
if $GET(ACTIONCODE)="NB"
QUIT
+28 WRITE !!,"This encounter does not have a K#."
End DoDot:1
+29 ;
+30 IF $GET(IBBILL)'=""
Begin DoDot:1
+31 WRITE !,"ACC CLAIM/BILL "_IBBILL_" SELECTED"
HANG 2
End DoDot:1
+32 IF '$TEST
Begin DoDot:1
+33 ;TPF;IB*2*770v37;EBILL-5755
if $GET(ACTIONCODE)="NB"
QUIT
+34 WRITE !,"X12 ENCOUNTER NUMBER: ",$PIECE($GET(^IBA(364.9,IBENCIFN,0)),U,15),!
End DoDot:1
+35 ;
+36 DO FULL^VALM1
+37 ;
+38 ;IEN OF ASSIGNING GROUP
SET ACTGRPIEN=$ORDER(^IBA(364.92,ACTCODEIEN,5,"B",USERGROUP,0))
+39 SET ASSIGNGRP=USERGROUP
+40 ;
+41 if $GET(ACTGRPIEN)'=""
SET ASSIGNTOGRPIEN=$ORDER(^IBA(364.92,ACTCODEIEN,5,ACTGRPIEN,5,0))
+42 if $GET(ASSIGNTOGRPIEN)'=""
SET ASSIGNTOGRP=$GET(^IBA(364.92,ACTCODEIEN,5,ACTGRPIEN,5,ASSIGNTOGRPIEN,0))
+43 ;
+44 SET DEFSTATUS=$$GET1^DIQ(364.92,ACTCODEIEN,.03,"")
+45 ;
+46 ;TPF;IB*2*7077V6;EBILL=????;10/15/2024
IF DEFSTATUS'="CLOSED"
IF (ASSIGNTOGRPIEN="")!($PIECE($GET(^IBA(364.92,ACTCODEIEN,5,ACTGRPIEN,5,0)),U,3)>1)
IF (BATCHITEM=1)
Begin DoDot:1
+47 WRITE !!,"YOU CAN REASSIGN THIS ENCOUNTER TO THE FOLLOWING GROUPS:"
+48 NEW CODES,DA,DIR,ALLOWEDGRPS,CODESLIST
+49 ;S CODES=$P($G(^DD(364.925,.01,0)),U,3)
+50 ;MJL fix
DO FIELD^DID(364.925,.01,"","POINTER","CODESLIST")
+51 ;MJL fix
SET CODES=$GET(CODESLIST("POINTER"))
+52 SET ALLOWEDGRPS=$PIECE(CODES,";HIMS:HEALTH INFORMATION MANAGEMENT",1)_$PIECE(CODES,";HIMS:HEALTH INFORMATION MANAGEMENT",2)
+53 ;!(Y'=""HIMS"")" ;TPF;IB*2*7077V6;EBILL=????;10/15/2024
SET DIR("S")="I Y'=ASSIGNGRP"
+54 SET DIR(0)="S^"_ALLOWEDGRPS
+55 DO ^DIR
+56 SET (BATCHGROUP,ASSIGNTOGRP)=Y
End DoDot:1
IF ASSIGNTOGRP=U
SET VALMBCK="R"
QUIT
+57 ;
+58 IF $GET(BATCHITEM)>1
IF $DATA(BATCHGROUP)
SET ASSIGNTOGRP=BATCHGROUP
+59 ;
+60 ;UPDATE PREVIOUS ACTIVITY
+61 SET ADDIENS="+1,"_IBENCIFN_","
+62 SET ADDFDA(364.94,ADDIENS,.01)="NOW"
+63 SET ADDFDA(364.94,ADDIENS,.02)="`"_$GET(DUZ)
+64 SET ADDFDA(364.94,ADDIENS,.03)="`"_$GET(ACTCODEIEN)
+65 SET ADDFDA(364.94,ADDIENS,.04)=$GET(ASSIGNGRP)
+66 SET ADDFDA(364.94,ADDIENS,.05)=$GET(ASSIGNTOGRP)
+67 ;
+68 DO UPDATE^DIE("ES","ADDFDA","ADDIENS","ADDERR")
+69 ;
+70 ;TPF;IB*2*770v11;EBILL-4523 ;CHANGE TO SOP FOR ERROR CHECKS IN WL
IF $DATA(ADDERR)
Begin DoDot:1
+71 WRITE !!,"Problem adding Previous Activity Multiple for Encounter. Report to eBilling"
SET VALMBCK="R"
+72 WRITE !,$GET(ADDERR("DIERR",1,"TEXT",1))
+73 NEW DIR,DIRUT,DUOUT,DTOUT
+74 DO PAUSE^VALM1
End DoDot:1
QUIT
+75 ;
+76 SET DA=ADDIENS(1)
+77 SET DA(1)=IBENCIFN
+78 ;EDIT PREVIOUS ACTIVITY
DO EDITPREVACT(.DA,.DEFSTATUS,.ASSIGNTOGRP,.ESCAPE,BATCHITEM,.BATCHCOMMENT)
+79 ;
+80 ;TPF;IB*2*770v32;EBILL-5503
DO FULL^VALM1
+81 ;AT THIS POINT THE UPDATE AND REASSIGNMENT IS SUCCESSFUL SO LETS UPDATE CURRENT SCREEN
+82 ;AND MOVE THE ENTRY TO OTHER SCREENS IF THEY ARE ACTIVE
+83 ;
+84 ;TPF;IB*2*770v38;EBILL-5485,5721
IF $GET(IBPARENT)=0
DO EEPUBLISH^IBACCWLUTIL1(IBDAIEN,.IBFROMVALMDDF,"",.LASTONEPUBLISHED)
SET VALMBCK="R"
QUIT
+85 ;
+86 ;UPDATE THIS USER'S SCREEN LIST
+87 if $DATA(VALMDDF("ASSIGNEDGRP"))
DO FLDTEXT^VALM10(IBDAIEN,"ASSIGNEDGRP",$GET(ASSIGNTOGRP))
+88 ;# MEANS ENCOUNTER HAS BEEN REASSIGNED OR SUCCESSFULLY RESUBMITTED AND UNAVAILABLE IN THE CURRENT WORKLIST
if $DATA(VALMDDF("INDICATOR"))
DO FLDTEXT^VALM10(IBDAIEN,"INDICATOR","# ")
+89 IF $DATA(VALMDDF("PREVACT"))
if $GET(ACTCODEIEN)
SET PREVACTIVITY=$PIECE($GET(^IBA(364.92,ACTCODEIEN,0)),U)_" "_$EXTRACT($PIECE($GET(^IBA(364.92,ACTCODEIEN,0)),U,2),1,$PIECE(VALMDDF("PREVACT"),U,3))
+90 if $DATA(VALMDDF("PREVACT"))
DO FLDTEXT^VALM10(IBDAIEN,"PREVACT",$GET(PREVACTIVITY))
+91 ;
+92 IF $GET(ASSIGNTOGRP)'=""
Begin DoDot:1
+93 SET @VALMAR@(IBDAIEN,"UNAVAILABLE")="RECORD HAS BEEN REASSIGNED. ON YOUR NEXT LOG IN YOU WILL NOT SEE THIS ENTRY."
+94 if $DATA(VALMDDF("DATEASSNED"))
DO FLDTEXT^VALM10(IBDAIEN,"DATEASSNED",$$FMTE^XLFDT($$GET1^DIQ(364.9,IBENCIFN_",",3.03,"I"),"2ZD"))
End DoDot:1
+95 ;
+96 ;UPDATE OTHER USERS IN ASSIGNED TO GROUP
if $GET(PUBLISHINGON)&($GET(ASSIGNTOGRP)'="")
DO PUBLISH^IBACCWLUTIL(ASSIGNGRP,IBENCIFN,IBDAIEN,ASSIGNTOGRP,.VALMDDF,.PUBSUCCESS,IBDAIEN,.LASTONEPUBLISHED)
+97 ;
+98 SET VALMBCK="R"
+99 ;
+100 QUIT
+101 ;
EDITPREVACT(DA,DEFSTATUS,ASSIGNTOGRP,ESCAPE,BATCHITEM,BATCHCOMMENT) ;EP- EDIT PREVIOUS ACTIVITY
+1 NEW DIE,ERROR,PREVACTIENS,PREVACTRET,RETURN
+2 ;
+3 SET ESCAPE=0
+4 ;
+5 ;CHANGE STATUS BASED ON ACTIVITY CODE
+6 IF $GET(DEFSTATUS)=""
DO EDITSTATUS^IBACCWLUTIL(DA(1),.DEFSTATUS)
+7 IF '$TEST
DO UPDSTATUS^IBACCWLUTIL(DA(1),.DEFSTATUS)
+8 ;
+9 ;IF STATUS CLOSED DO NOT ASK FOR A GROUP TO REASSIGN TO
IF DEFSTATUS'="CLOSED"
Begin DoDot:1
+10 IF $GET(ASSIGNTOGRP)=""
DO EDITAS2GRP^IBACCWLUTIL(DA(1),.ASSIGNTOGRP)
+11 ;TPF;IB*2*770v23;EBILL-5036
IF '$TEST
DO UPDAS2GRP^IBACCWLUTIL(DA(1),.ASSIGNTOGRP,1)
End DoDot:1
+12 ;
+13 ;TPF;IB*2*770v32;EBILL-5503
+14 ;TPF;IB*2*770v37;EBILL-5789
IF $GET(ACTCODENUM)'=1
IF ($GET(ACTIONCODE)'="NB")
Begin DoDot:1
+15 NEW DIR
+16 SET DIR(0)="E"
+17 ; EBILL-5859;WCJ;v39
SET DIR("A")="Type <Enter> to continue"
+18 DO ^DIR
End DoDot:1
+19 ;
+20 ;
+21 SET PREVACTIENS=$$IENS^DILF(.DA)
+22 IF BATCHITEM=1
Begin DoDot:1
+23 WRITE !!,"Enter a comment so processing can fully be documented and the Reassignment"
+24 WRITE !,"Group knows what has already been done or might be requested to do."
+25 ;TPF;IB*2*770v38;EBILL-5825
WRITE !,"This comment will be applied to "_$SELECT($GET(IBDA("TOTAL"))>1:"the entire batch.",1:"this encounter.")
+26 WRITE !
+27 ;
+28 SET DIE="^IBA(364.9,"_DA(1)_",4,"
+29 SET DR=""
+30 SET DR=DR_"10"
+31 DO ^DIE
+32 DO GETS^DIQ(364.94,PREVACTIENS,"**","EIR","PREVACTRET","ERROR")
+33 MERGE BATCHCOMMENT=PREVACTRET(364.94,PREVACTIENS,"PREVIOUS ACTIVITY COMMENTS")
+34 KILL BATCHCOMMENT("E")
+35 KILL BATCHCOMMENT("I")
End DoDot:1
QUIT
+36 ;
+37 ;THIS MEANS WE HAVE ALREADY CREATED A COMMENT IF BATCHITEM=1
IF BATCHITEM>1
IF $DATA(BATCHCOMMENT)
Begin DoDot:1
+38 KILL WPERR
DO EDITPREVACT^IBACCWLUTIL(PREVACTIENS,.BATCHCOMMENT,.WPERR)
+39 ;TPF;IB*2*770v11;EBILL-4523 ;CHANGE TO SOP FOR ERROR CHECKS IN WL
IF $DATA(WPERR)
Begin DoDot:2
+40 WRITE !!,"Problem adding comment to Encounter. Report to eBilling"
+41 SET VALMBCK="R"
+42 WRITE !,$GET(WPERR("DIERR",1,"TEXT",1))
+43 NEW DIR,DIRUT,DUOUT,DTOUT
+44 DO PAUSE^VALM1
End DoDot:2
End DoDot:1
QUIT
+45 ;
+46 SET VALMBCK="R"
+47 QUIT
+48 ;
SEL(IBDA,OPTION) ;EP -
+1 KILL IBDA,VALMY
+2 DO FULL^VALM1
+3 DO EN^VALM2($GET(XQORNOD(0)),$SELECT($GET(OPTION)'="":OPTION,1:"S"))
+4 if '$DATA(VALMY)
QUIT
+5 ;
+6 SET IBDA("TOTAL")=0
+7 SET IBDA=0
+8 FOR
SET IBDA=$ORDER(VALMY(IBDA))
if 'IBDA
QUIT
Begin DoDot:1
+9 SET IBDA(IBDA)=$GET(@VALMAR@(+IBDA,0))
+10 SET IBDA("TOTAL")=IBDA("TOTAL")+1
End DoDot:1
+11 ;ONLY IF ONE SELECTION. NEED A FOR LOOP FOR MULTIPLES
SET IBDA=$ORDER(IBDA(""))
+12 ;
+13 QUIT
