IBACCWLUTIL1 ;EDE/TPF - ACC (Automated Community Care) Encounters utility APIs (Cont.) ; 12-SEP-2023
;;2.0;INTEGRATED BILLING;**770**;21-MAR-2024;Build 119
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to $P($G(^DPT(DFN,.3)),U) in ICR #426
;
Q
;
;CALLED FROM CONVERTDFF^IBACCWLUTIL TO CONVERT VALMDDF FOR PUBLISHING
SUBDATAUPDATE(LINE,IBENCIFN,IBDAIEN,VALMDFFFROM,VALMDFFTO) ;EP - UPDATE SUBSRIBER COLUMN DATA
;
N FIELD,TOCOLUMN,TOWIDTH,IBDATALINE ;PUBTO,PUBFROM,VALMARFROM,VALMARTO
;
S IBDATALINE=LINE
;
S FIELD=""
F S FIELD=$O(VALMDFFTO(FIELD)) Q:FIELD="" D
.Q:FIELD="LINENUM"!($D(VALMDFFFROM(FIELD))) ;IF FIELD EXIXTS IN THE PUBLISHERS COLUMNS NO NEED TO PULL DATA BECAUSE IT WAS TRANSFERRED IN CONVERTDFF^IBACCWLUTIL
.S TOCOLUMN=$P(VALMDFFTO(FIELD),U,2)
.S TOWIDTH=$P(VALMDFFTO(FIELD),U,3)-1
.S TODATA=("S TODATA=$$"_FIELD_"("_IBENCIFN_")")
.X TODATA
.S IBDATALINE=$$SETSTR^VALM1(TODATA,IBDATALINE,TOCOLUMN,TOWIDTH) ;TOCOLUMN+TOWIDTH
;
S LINE=IBDATALINE
;
Q
;
DIVNAME(IBENCIFN) ;GET DIVISION NAME ;TPF;IB*2*770V32;EBILL-5411
N SITENUM,DIVIEN,DIVNAME
S SITENUM=$$GET1^DIQ(364.9,IBENCIFN_",",.2)
S:SITENUM DIVIEN=$$LKUP^XUAF4(SITENUM)
S DIVNAME=$$GET1^DIQ(4,DIVIEN_",",.01,"E")
Q DIVNAME
;
FORMTYPE(IBENCIFN) ;GET FOMRTYPE
N FORMTYPE
S FORMTYPE=$$GET1^DIQ(364.9,IBENCIFN_",",.06)
Q FORMTYPE
;
FACNPI(IBENCIFN) ;GET FACILITY NPI ??? WHERE IS THIS
N NPI
S NPI=$$GET1^DIQ(364.9,IBENCIFN_",",.09)
Q NPI
;
PROVNPI(IBENCIFN) ;GET PROVIDER NPI
N NPI
S NPI=$$GET1^DIQ(364.9,IBENCIFN_",",.09)
Q NPI
;
CPT(IBENCIFN) ;GET CPT
N CPT
S CPT=$$GET1^DIQ(364.9,IBENCIFN_",",.13)
Q CPT
;
DOB(IBENCIFN) ;GET DOB
Q $$FMTE^XLFDT($$GET1^DIQ(364.9,IBENCIFN_",",.1,"I"),"2ZD")
;
PRIMDX(IBENCIFN) ;GET PRIMDX
Q $$GET1^DIQ(364.9,IBENCIFN_",",.14)
;
STATUS(IBENCIFN) ;GET STATUS
Q $$GET1^DIQ(364.9,IBENCIFN_",",.16)
;
PRIMINSUR(IBENCIFN) ;GET PRIMARY INSURANCE
Q $$GET1^DIQ(364.9,IBENCIFN_",",.17)
;
SECINSUR(IBDAIEN) ;GET SECONDARY INSURANCE
Q $$GET1^DIQ(364.9,IBENCIFN_",",.18)
;
SERVCON(IBENCIFN) ;GET SERVICE CONNECTED
N SERVCON
I $G(DFN) S SERVCON=$P($G(^DPT(DFN,.3)),U) ;ICR #426 (Private)
E S SERVCON="UNK"
Q SERVCON
;
ASSIGNEDGRP(IBENCIFN) ;GET ASSIGNED GROUP
Q $$GET1^DIQ(364.9,IBENCIFN_",",3.01,"I")
;
BILLNUM(IBENCIFN) ;GET BILL NUMBER
N BILL
S BILL=$$GET1^DIQ(364.9,IBENCIFN_",",2.02)
I 'BILL D
.S BILL=$$GET1^DIQ(364.9,IBENCIFN_",",.15)
.S BILL=$E(BILL,($L(BILL)-$P(VALMDFFTO("BILLNUM"),U,3))+1,$L(BILL))
Q BILL
;
DATEASSNED(IBENCIFN) ;GET DATE ASSIGNED
Q $$FMTE^XLFDT($$GET1^DIQ(364.9,IBENCIFN_",",3.03,"I"),"2ZD")
;
DAYSONWL(IBENCIFN) ;GET DAYS ON THE WORKLIST
Q $$GET1^DIQ(364.9,IBENCIFN_",",.23)
;
INDICATOR(IBENCIFN) ;GET INDICATOR
N PATNOTFOUND,STATUS,VISMARK
S PATNOTFOUND=$D(^IBA(364.9,IBENCIFN,5,"B",1)) ;1 = #364.91 - PAT NOT FOUND IS CODE 1
S STATUS=$$GET1^DIQ(364.9,IBENCIFN_",",.16,"I")
S VISMARK=$S(PATNOTFOUND:"!",1:"")
S VISMARK=VISMARK_$S(STATUS=1:"*",1:"") ;* = 'IN PROGRESS' ! = PAT NOT IN #200
Q $G(VISMARK)
;
PATTYPE(IBENCIFN) ;GET PATIENT TYPE
Q $$GET1^DIQ(364.9,IBENCIFN_",",.05,"I")
;
PREVACT(IBENCIFN) ;GET LAST PREVIOUS ACTIVITY
N PREVACTIEN,ACTCODEIENS,ACTRTEUN,ACTERROR
S PREVACTIEN=$O(^IBA(364.9,IBENCIFN,4,99999),-1)
I PREVACTIEN D
.S ACTCODEIENS=$P(^IBA(364.9,IBENCIFN,4,PREVACTIEN,0),U,3)_","
.D GETS^DIQ(364.92,ACTCODEIENS,".01;.02;","E","ACTRETURN","ACTERROR")
.S PREVACTIVITY=$G(ACTRETURN(364.92,ACTCODEIENS,.01,"E"))_" "_$E($G(ACTRETURN(364.92,ACTCODEIENS,.02,"E")),1,50)
Q $G(PREVACTIVITY)
;
PROVIDER(IBENCIFN) ;GET PROVIDER
Q $$GET1^DIQ(364.9,IBENCIFN_",",.07,"I")
;
REASCODE(IBENCIFN) ;GET REASON CODE
N REASON,REASCODE,REASIEN,REASONPTR
S REASIEN=$O(^IBA(364.9,IBENCIFN,5,0))
I REASIEN D
.S REASONPTR=$P($G(^IBA(364.9,IBENCIFN,5,REASIEN,0)),U)
.I REASONPTR'="" D
..S REASCODE=$$RJ^XLFSTR($P($G(^IBA(364.91,REASONPTR,0)),U),3," ")
..S REASON=$P($G(^IBA(364.91,REASONPTR,0)),U,2)
.S REASON=$G(REASCODE)_" "_$G(REASON)
Q $G(REASON)
;
SERVDATE(IBENCIFN) ;GET SERVICE DATE
Q $$FMTE^XLFDT($$GET1^DIQ(364.9,IBENCIFN_",",.12,"I"),"2ZD")
;
SERVFAC(IBENCIFN) ;GET SERVICE FACILITY
Q $$GET1^DIQ(364.9,IBENCIFN_",",.2,"I")
;
SSN(IBENCIFN) ;GET SERVICE FACILITY
Q $E($$GET1^DIQ(364.9,IBENCIFN_",",.11,"I"),6,9)
;
;PUBLISH CHANGE TO JUST ONE FIELD
FIELDPUBLISH(FIELD,FIELDVALUE,IBENCIFN,PUBSUCCESS) ;EP - PLACE DATA TO PUBLISH TO OTHER ACC ENCOUNTER WORK GROUP USERS INTO THEIR DATA GLOBALS
;
N IBTOIBDA,LASTONE,LINE,JOB,SUBCRIBEGRP,X,VALMAR
;
S FIELD=$P(FIELD,U)
;
S PUBSUCCESS=0
S SUBCRIBEGRP="IBACCWL"
F S SUBCRIBEGRP=$O(^TMP(SUBCRIBEGRP)) Q:SUBCRIBEGRP=""!(SUBCRIBEGRP'[("IBACCWL")) D
.S JOB=0
.F S JOB=$O(^TMP(SUBCRIBEGRP,JOB)) Q:'JOB D
..;
..Q:JOB=$J ;DO NOT ASSIGN TO SELF
..;
..I $G(^TMP(SUBCRIBEGRP,JOB,2,0))[("NO DATA FOUND") K ^TMP(SUBCRIBEGRP,JOB) Q ;DEAL WITH THAT ONE VERY LOW POSSIBLE SITUATION A S LASTONEPUBLISHED=1
..;
..Q:'$D(^TMP(SUBCRIBEGRP,$J,"IEN3649",IBENCIFN)) ;=348
..;
..;UPDATE ENTRY IN WORKLIST
..S IBTOIBDA=$G(^TMP(SUBCRIBEGRP,JOB,"IEN3649",IBENCIFN))
..Q:IBTOIBDA="" ;TPF;IB*2*770v9;EBILL-4482 IF THIS NODE IS NOT THERE IT IS A CORRUPT REC. OR WAS DELETED BEFORE THIS PUBLISH OCCURED
..S VALMAR="^TMP("""_SUBCRIBEGRP_""","_JOB_")"
..D FLDTEXT^VALM10(IBTOIBDA,FIELD,FIELDVALUE)
;
Q
;
TRANSMITTED(IBIFN) ;EP - CHECK BILL FOR TRANSMISION STATUS
;
N STATUS
S STATUS=$$GET1^DIQ(399,IBIFN_",",.13,"E") ;STATUS
;JWS;7/31/25;EBILL-5712;IB*2.0*770v38;added AUTHORIZED as a successful status (commercial claims until transmitted)
Q (STATUS="REQUEST MRA")!(STATUS="PRNT/TX")!(STATUS="AUTHORIZED")
;
;CALLED BY IBACCWLAIVIEW
ASKSTATUS(REQUIRED) ;EP - ASK STATUS ONLY FOR BACTH PROCESSING
;
N DIR,SETOFCODES,DUOUT,DTOUT,DIROUT
N TARGET,MESSAGE ;WCJ;XINDEX;TEAL
;
STA ;
;S SETOFCODES=$P($P($G(^DD(364.9,.16,0)),U,3),";",1,3) ;"STATUS^S^0:OPEN;1:IN PROGRESS;2:CLOSED;3:PURGED;
D FIELD^DID(364.9,.16,"N","POINTER","TARGET","MESSAGE") ;WCJ;XINDEX;TEAL
;S SETOFCODES=TARGET("POINTER",";",1,3) ;WCJ;XINDEX;TEAL
S SETOFCODES=$P(TARGET("POINTER"),";",1,3) ;TPF;XINDEX;TEAL
S DIR(0)="S^"_SETOFCODES
S DIR("A")="BATCH STATUS"
D ^DIR
I $D(DUOUT)!$D(DTOUT)!$D(DIROUT),(REQUIRED),(X="@") G STA
Q:$D(DUOUT)!$D(DTOUT)!$D(DIROUT) 0 ;W !!,"FIELD REQUIRED!" G STA
S STATUS=Y(0)
Q STATUS
;
AVAILABLECHK(IBDA) ;EP - CHECK IF RECORD HAS BEEN REASSIGNED AND THEREFOREE UNAVAILABEL TOI THE CURRENT USER
;
N IBENCIFN,IBDAIEN
I $D(IBFROMVALMDDF) N VALMAR S VALMAR=$G(IBFROMVALMDDF(1,"VALMAR")) Q:VALMAR="" ;TPF;IB*2*770v38;EBILL-5485,5721
S IBDAIEN=0
;
I '$O(IBDA("")),$G(IBDA) W !!,"RECORD IS NO LONGER AVAILABLE." N DIR D PAUSE^VALM1 Q ;TPF;IB*2*770v48;EBILL-6095
;
F S IBDAIEN=$O(IBDA(IBDAIEN)) Q:'IBDAIEN D
.;
.I $D(@VALMAR@(IBDAIEN,"UNAVAILABLE")) D
..W !,"RECORD "_IBDAIEN_" IS NO LONGER AVAILABLE BECAUSE "
..W !,$G(@VALMAR@(IBDAIEN,"UNAVAILABLE"))
..W !,$S($G(IBDA("TOTAL"))>1:"RECORD WILL BE REMOVED FROM THE BATCH.",1:"RECORD CAN NOT BE PROCESSED!") ;TPF;IB*2*770v????;EBILL-9999
..K IBDA(IBDAIEN) ;REMOVE FROM BATCH
..S VALMBCK="R"
..N DIR ;TPF;IB*2*770v47;EBILL-6042
..D PAUSE^VALM1
..;
.;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)) ;TMP("IBACCWLEE",2866858,"IEN3649",1)=683
..S IBENCIFN=$G(^TMP("IBACCWLEE",$J,"IEN3649",1)) ;;TPF;IB*2*770v48;EBILL-6095
.E D
..S IBENCIFN=$G(@VALMAR@(IBDAIEN,"IEN3649",1))
.;
.I $$STATUS^IBACCWLUTIL1(IBENCIFN)="CLOSED" D Q
..W !,"THIS RECORD IS NO LONGER AVAILABLE BECAUSE "
..W !,"IT HAS BEEN CLOSED!"
..W !,$S($G(IBDA("TOTAL"))>1:"RECORD WILL BE REMOVED FROM THE BATCH.",1:"RECORD CAN NOT BE PROCESSED!") ;TPF;IB*2*770vPURPLE;EBILL-9999
..K IBDA(IBDAIEN) ;REMOVE FROM BATCH
..S VALMBCK="R"
..N DIR ;TPF;IB*2*770v47;EBILL-6042
..D PAUSE^VALM1
..;
;
I $D(IBDA)=1 K IBDA D
.W !!,"THE SELECTED RECORD(S) HAVE BEEN REASSIGNED."
.W !,"YOU CAN NO LONGER SELECT THIS RECORD!"
I '$D(IBDA) W !,"ALL SELECTIONS HAVE BEEN REASSIGNED" N DIR D PAUSE^VALM1 Q ;TPF;IB*2*770v47;EBILL-6042
;
Q
;
;TPF;IB*2*770vPURPLE;EBILL-5466
NBSCREEN(IBDA) ;EP - SCREEN FOR ACTION NB WHERE THE K# IS NOT CANCELLED YET
;
N IBBILL,IBIFN,IBENCIFN,IBDAIEN,ORIGBTOT
S ORIGBTOT=IBDA("TOTAL")
W !
S IBDAIEN=0
F S IBDAIEN=$O(IBDA(IBDAIEN)) Q:'IBDAIEN D
.;
.I $G(IBDA(IBDAIEN))["-------------" K IBDA(IBDAIEN) S IBDA("TOTAL")=IBDA("TOTAL")-1 Q
.;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))
.E D
..S IBENCIFN=$G(@VALMAR@(IBDAIEN,"IEN3649",1))
.Q:'$G(IBENCIFN)
.;
.S IBIFN=$$GET1^DIQ(364.9,IBENCIFN_",",2.02,"I")
.Q:IBIFN=""
.;
.I '$$CANCELLED(IBIFN) D
..S IBBILL=$$GET1^DIQ(399,IBIFN_",",.01,"E")
..W !!,$G(IBBILL)_" is not cancelled and cannot be closed via NB!"
..W:(ORIGBTOT>1) !,"Encounter has been removed from the batch."
..K IBDA(IBDAIEN)
..S IBDA("TOTAL")=IBDA("TOTAL")-1
;
K:IBDA("TOTAL")=0!(IBDA("TOTAL")<0) IBDA("TOTAL")
;
I $D(IBDA)=1 K IBDA D
.W:(ORIGBTOT>1) !!,"NO ITEMS LEFT IN THE BATCH!"
.N DIR ;TPF;IB*2*770v47;EBILL-6042
.D PAUSE^VALM1
;
Q
CANCELLED(IBIFN) ;EP - CHECK BILL FOR CANCELLED STATUS
;
N STATUS
S STATUS=$$GET1^DIQ(399,IBIFN_",",.13,"E") ;STATUS
Q (STATUS="CANCELLED")
;
;TPF;IB*2*770vPURPLE;EBILL-5715
IPSCREEN(IBDA) ;EP - SCREEN FOR ACTIVITY CODE 506 - APPLIES TO ONLY IP
;
N IBENCIFN,IBDAIEN,IBTYPE,IBENC,ORIGBTOT ;EBILL-5946;v42
S ORIGBTOT=IBDA("TOTAL") ;EBILL-5946;v42
W !
S IBDAIEN=0
F S IBDAIEN=$O(IBDA(IBDAIEN)) Q:'IBDAIEN D
.I $G(IBDA(IBDAIEN))["--------------" K IBDA(IBDAIEN) S IBDA("TOTAL")=IBDA("TOTAL")-1 Q
.;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))
.E D
..S IBENCIFN=$G(@VALMAR@(IBDAIEN,"IEN3649",1))
.;
.Q:'$G(IBENCIFN)
.;
.S IBTYPE=$$GET1^DIQ(364.9,IBENCIFN_",",.05,"E")
.Q:IBTYPE="IN-PATIENT" ;506 FOR IP IS OK
.;
.S IBBILL=$$GET1^DIQ(364.9,IBENCIFN_",",2.02,"E")
.S:IBBILL="" IBBILL=$$GET1^DIQ(364.9,IBENCIFN_",",.15)
.;
.W !!,"Activity Code 506 is for Inpatient encounters only."
.W:(ORIGBTOT>1) !,IBBILL," has been removed from the batch." ;EBILL-5946;v42
.K IBDA(IBDAIEN)
.S IBDA("TOTAL")=IBDA("TOTAL")-1
;
K:IBDA("TOTAL")=0!(IBDA("TOTAL")<0) IBDA("TOTAL")
;
I $D(IBDA)=1 K IBDA D
.W:(ORIGBTOT>1) !,"NO ITEMS LEFT IN THE BATCH!" ;EBILL-5946;v42
.N DIR ;TPF;IB*2*770v47;EBILL-6042
.D PAUSE^VALM1
;
Q
;
;EBILL-5130 RESEARCHING CAUSE OF <UNDEFINED>FLDTEXT+5^VALM10. CAN NOT REPLICATE
;ERROR REALLY OCCURRS IN EEPUBLISH+12^IBACCWLUTIL1 BECAUSE THE VALMAR OF PARENT WL IS GONE
;COMMENT PLACED HERE BECAUSE IBACCWLAIBILL WAS TOO BIG
EEPUBLISH(IBDAIEN,IBFROMVALMDDF,SUCCESS,LASTONEPUBLISHED) ;EP - MUST COME HERE TO PUBLISH FROM EE/RE-ASSIGN, RA-RESUBMIT
;UPDATE THE APPROPRIATE USER'S SCREEN LIST. IF CALLING FROM AN EE THEN UPDATE THE DATA ARRAY FOR THE WL THEY CALLED EE FROM
;SUCCESS IS ONLY DEFINED IN THE RA - RESUBMIT ACTION ITEM IN RESUBMITLOOP^IBACCWLAIBILL
N VALMAR,VALMDDF
S VALMAR=$G(IBFROMVALMDDF(1,"VALMAR"))
Q:VALMAR=""
M VALMDDF=IBFROMVALMDDF
;
I $G(SUCCESS) D
.S @VALMAR@(IBDAIEN,"UNAVAILABLE")="RECORD HAS BEEN REASSIGNED OR RESUBMITTED. ON YOUR NEXT LOG IN YOU WILL NOT SEE THIS ENTRY."
.D:$D(IBFROMVALMDDF("INDICATOR")) FLDTEXT^VALM10(IBDAIEN,"INDICATOR","# ") ;TPF;IB*2*770v35;EBILL-5728
;
D:$D(IBFROMVALMDDF("ASSIGNEDGRP")) FLDTEXT^VALM10(IBDAIEN,"ASSIGNEDGRP",$G(ASSIGNTOGRP))
;
;I '$D(^TMP("IBACCWLEE",$J,IBDAIEN,0)) Q ;TPF;EBILL-5130??? SHOULD BE ^TMP("IBACCWLFRT" OR ANY PARENT WL VALMAR IS WRONG
I $G(CURASSIGGRP)'=$$ASSIGNEDGRP^IBACCWLUTIL1(IBENCIFN) D ;TPF;IB*2*770v35;EBILL-5728
.S @VALMAR@(IBDAIEN,"UNAVAILABLE")="RECORD HAS BEEN REASSIGNED. ON YOUR NEXT LOG IN YOU WILL NOT SEE THIS ENTRY."
.D:$D(IBFROMVALMDDF("INDICATOR")) FLDTEXT^VALM10(IBDAIEN,"INDICATOR","# ")
;
D:$D(IBFROMVALMDDF("PREVACT")) FLDTEXT^VALM10(IBDAIEN,"PREVACT",$G(PREVACTIVITY))
I $D(IBFROMVALMDDF("PREVACT")) S PREVACTIVITY=$$PREVACT^IBACCWLUTIL1(IBDAIEN)
;
D:$G(PUBLISHINGON)&($G(ASSIGNTOGRP)'="") PUBLISH^IBACCWLUTIL(ASSIGNGRP,IBENCIFN,IBDAIEN,ASSIGNTOGRP,.IBFROMVALMDDF,.PUBSUCCESS,IBDAIEN,.LASTONEPUBLISHED) ;UPDATE OTHER USERS IN ASSIGNED TO GROUP
;
Q
;
;USED BY X-REF
;W $$PTNAME^IBACCWLUTIL1(34)
PTNAME(IBENCIFN) ;EP - COMBINE NAME FIELD SIN #364.9 INTOVISTA TYPE NAME FOR NAME LOOKUP X-REF
;
N FNAME,LNAME,MNAME
S LNAME=$P($G(^IBA(364.9,IBENCIFN,0)),U,2)
S FNAME=$P($G(^IBA(364.9,IBENCIFN,0)),U,3)
S MNAME=$P($G(^IBA(364.9,IBENCIFN,0)),U,4)
Q:LNAME=""&(FNAME="")&(MNAME="") "UNDEF"_U_IBENCIFN
;
Q LNAME_","_FNAME_" "_MNAME
;
;DAYS ON WORKGROUP WORKLIST
;W $$DAYSONWRKGRP^IBACCWLUTIL1(1)
DAYSONWRKGRP(IBENCIFN) ;COMPUTE DAYS ON WORKGROUP WORKLIST
;
Q:'$G(IBENCIFN)
;
N DTASSIGNED,IENS,STATUS,STATUSDTCHANG,X,Y,X1,X2,%Y
S IENS=IBENCIFN_","
S STATUSDTCHANG=$$GET1^DIQ(364.9,IENS,.22,"I") ;DATE STATUS WAS CHANGED. IF STATUS=CLOSED USE AS STOP OF CLOCK
S DTASSIGNED=$$GET1^DIQ(364.9,IENS,3.03,"I") ;DATE ENCOUNTER ASSIGNED TO GROUP IN FIELD #3.01 ASSIGNED TO GROUP
S STATUS=$$GET1^DIQ(364.9,IENS,.16,"I") ;CURRENT STATUS OF THE ENCOUNTER
;'0' FOR OPEN;
;'1' FOR IN PROGRESS;
;'2' FOR CLOSED;
;'3' FOR PURGED;
;
I STATUS=2 D ;2 = CLOSED THIS WILL BE USED FOR AUDIT REPORT?
.S X1=STATUSDTCHANG
.S X2=DTASSIGNED
.D ^%DTC ;X2 IS SUBTRACTED FROM X1
.I $G(%Y) S DAYS=X
.E S DAYS="ERR"
E D
.S X1=DT
.S X2=DTASSIGNED
.D ^%DTC
.I $G(%Y) S DAYS=X
.E S DAYS="ERR"
;
Q DAYS
;
;;TPF*IB*2*770v20;EBILL=4462,4928 ADD SECONDARY DX
CONVERT2DEC(SECONDX,EEDXDISPLAY) ;EP - CONVERT SECONDARY DX STRING IN FIELD .3 FILE #364.9 TO READABLE DECIMAL
;
Q:$G(SECONDX)?." " "" ;TPF;IB*2*770V20 ;TPF*IB*2*770v20;EBILL=4928 DEAL WITH NULL DX PASSED
N LENGTH,PIECE,RETDX,SECDX
S RETDX=""
S LENGTH=$L(SECONDX,",")-1
F PIECE=1:1 S SECDX=$P(SECONDX,",",PIECE) Q:SECDX="" D
.I PIECE'=LENGTH S RETDX=RETDX_$$ICDLKUP(SECDX)_", "
.S EEDXDISPLAY(PIECE)=$$ICDLKUP(SECDX)
.E S RETDX=RETDX_$P($$ICDLKUP(SECDX)," ")
;
Q RETDX
;TPF;IB*2*770v18;EBILL-4623 PROVIDED BY TIM Z. BUT MODIFIED
;W $$ICDLKUP^IBACCWLUTIL1("J329")
;TAZ;IB*2*770v19;EBILL-4938
ICDLKUP(IC) ;Look up the ICD Code desciption v12
;
Q:$G(IC)?." " "" ;TPF;IB*2*770V20 ;TPF*IB*2*770v20;EBILL=4928 DEAL WITH NULL DX PASSED
N ICDARY,DESC
N RSLT ;TPF XINDEX
S IC=$E(IC,1,3)_"."_$E(IC,4,$L(IC))
S RSLT=$$DIAGSRCH^LEX10CS(IC,.ICDARY) ;ICR #5681 (Supported)
S DESC="" D
. I RSLT<0 S DESC="Unknown Code" Q
. I $G(ICDARY(1,"IDS"))]"" S DESC=ICDARY(1,"IDS") Q
. I $G(ICDARY(1,"LEX"))]"" S DESC=ICDARY(1,"LEX") Q
. I $G(ICDARY(1,"MENU"))]"" S DESC=ICDARY(1,"MENU") Q
. S DESC="Unknown Code"
ICDLKUPQ ;Exit lookup
Q IC_" - "_DESC
;
;
HCPCSMANY(CODES,EDXDISPLAY) ;
Q:$G(CODES)=""
N PIECE,LENGTH
F PIECE=1:1 S CODE=$P(CODES,",",PIECE) Q:CODE="" D
.S EDXDISPLAY(PIECE)=$$HCPCS(CODE)
Q
;TPF;IB*2*770v18;EBILL-4623 PROVIDED BY TIM Z. BUT MODIFIED
HCPCS(CODE) ;CPT Code lookup
N CPTARY,RSLT
S RSLT=$$CPT^ICPTCOD(CODE,.CPTARY) ;ICR #1995 (Supported)
I RSLT'["" S CODE=CODE_" - Unknown Code" Q CODE
S CODE=CODE_" - "_$P(RSLT,U,3)
Q CODE
;
;and the modifier:
;TPF;IB*2*770v18;EBILL-4623 PROVIDED BY TIM Z. BUT MODIFIED
CPTMOD(CODE) ;CPT Code Modifier lookup v12
N CPTARY,RSLT
S RSLT=$$MOD^ICPTMOD(CODE,.CPTARY) ;ICR #1996 (Supported)
I RSLT'["" S CODE=CODE_" - Unknown Code" Q CODE
S CODE=CODE_" - "_$P(RSLT,U,3)
Q CODE
;
;TPF;IB*2*770v26;EBILL-5242
;S DFN=2 W $$ISSPECAUTH^IBACCWLUTIL1(DFN)
ISSPECAUTH(IBPATIEN) ;EP - RETURN Y/N FOR SPECIAL AUTHORITY
N IBRESLT,SA,SC ;TPF XINDEX
D CL^IBACV(IBPATIEN,,,.IBRESLT)
S (SC,SA)=" "
I $D(IBRESLT(1)) S SA="Y"
I $D(IBRESLT(2)) S SA="Y"
I $D(IBRESLT(3)) S SC="Y" ;"SERVICE CONNECTED"
I $D(IBRESLT(4)) S SA="Y"
I $D(IBRESLT(5)) S SA="Y"
I $D(IBRESLT(6)) S SA="Y"
I $D(IBRESLT(7)) S SA="Y"
I $D(IBRESLT(8)) S SA="Y"
;
S RET=" "_SC_"/"_SA
Q RET
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBACCWLUTIL1 16430 printed May 25, 2026@12:10:14 Page 2
IBACCWLUTIL1 ;EDE/TPF - ACC (Automated Community Care) Encounters utility APIs (Cont.) ; 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 ;
+4 ; Reference to $P($G(^DPT(DFN,.3)),U) in ICR #426
+5 ;
+6 QUIT
+7 ;
+8 ;CALLED FROM CONVERTDFF^IBACCWLUTIL TO CONVERT VALMDDF FOR PUBLISHING
SUBDATAUPDATE(LINE,IBENCIFN,IBDAIEN,VALMDFFFROM,VALMDFFTO) ;EP - UPDATE SUBSRIBER COLUMN DATA
+1 ;
+2 ;PUBTO,PUBFROM,VALMARFROM,VALMARTO
NEW FIELD,TOCOLUMN,TOWIDTH,IBDATALINE
+3 ;
+4 SET IBDATALINE=LINE
+5 ;
+6 SET FIELD=""
+7 FOR
SET FIELD=$ORDER(VALMDFFTO(FIELD))
if FIELD=""
QUIT
Begin DoDot:1
+8 ;IF FIELD EXIXTS IN THE PUBLISHERS COLUMNS NO NEED TO PULL DATA BECAUSE IT WAS TRANSFERRED IN CONVERTDFF^IBACCWLUTIL
if FIELD="LINENUM"!($DATA(VALMDFFFROM(FIELD)))
QUIT
+9 SET TOCOLUMN=$PIECE(VALMDFFTO(FIELD),U,2)
+10 SET TOWIDTH=$PIECE(VALMDFFTO(FIELD),U,3)-1
+11 SET TODATA=("S TODATA=$$"_FIELD_"("_IBENCIFN_")")
+12 XECUTE TODATA
+13 ;TOCOLUMN+TOWIDTH
SET IBDATALINE=$$SETSTR^VALM1(TODATA,IBDATALINE,TOCOLUMN,TOWIDTH)
End DoDot:1
+14 ;
+15 SET LINE=IBDATALINE
+16 ;
+17 QUIT
+18 ;
DIVNAME(IBENCIFN) ;GET DIVISION NAME ;TPF;IB*2*770V32;EBILL-5411
+1 NEW SITENUM,DIVIEN,DIVNAME
+2 SET SITENUM=$$GET1^DIQ(364.9,IBENCIFN_",",.2)
+3 if SITENUM
SET DIVIEN=$$LKUP^XUAF4(SITENUM)
+4 SET DIVNAME=$$GET1^DIQ(4,DIVIEN_",",.01,"E")
+5 QUIT DIVNAME
+6 ;
FORMTYPE(IBENCIFN) ;GET FOMRTYPE
+1 NEW FORMTYPE
+2 SET FORMTYPE=$$GET1^DIQ(364.9,IBENCIFN_",",.06)
+3 QUIT FORMTYPE
+4 ;
FACNPI(IBENCIFN) ;GET FACILITY NPI ??? WHERE IS THIS
+1 NEW NPI
+2 SET NPI=$$GET1^DIQ(364.9,IBENCIFN_",",.09)
+3 QUIT NPI
+4 ;
PROVNPI(IBENCIFN) ;GET PROVIDER NPI
+1 NEW NPI
+2 SET NPI=$$GET1^DIQ(364.9,IBENCIFN_",",.09)
+3 QUIT NPI
+4 ;
CPT(IBENCIFN) ;GET CPT
+1 NEW CPT
+2 SET CPT=$$GET1^DIQ(364.9,IBENCIFN_",",.13)
+3 QUIT CPT
+4 ;
DOB(IBENCIFN) ;GET DOB
+1 QUIT $$FMTE^XLFDT($$GET1^DIQ(364.9,IBENCIFN_",",.1,"I"),"2ZD")
+2 ;
PRIMDX(IBENCIFN) ;GET PRIMDX
+1 QUIT $$GET1^DIQ(364.9,IBENCIFN_",",.14)
+2 ;
STATUS(IBENCIFN) ;GET STATUS
+1 QUIT $$GET1^DIQ(364.9,IBENCIFN_",",.16)
+2 ;
PRIMINSUR(IBENCIFN) ;GET PRIMARY INSURANCE
+1 QUIT $$GET1^DIQ(364.9,IBENCIFN_",",.17)
+2 ;
SECINSUR(IBDAIEN) ;GET SECONDARY INSURANCE
+1 QUIT $$GET1^DIQ(364.9,IBENCIFN_",",.18)
+2 ;
SERVCON(IBENCIFN) ;GET SERVICE CONNECTED
+1 NEW SERVCON
+2 ;ICR #426 (Private)
IF $GET(DFN)
SET SERVCON=$PIECE($GET(^DPT(DFN,.3)),U)
+3 IF '$TEST
SET SERVCON="UNK"
+4 QUIT SERVCON
+5 ;
ASSIGNEDGRP(IBENCIFN) ;GET ASSIGNED GROUP
+1 QUIT $$GET1^DIQ(364.9,IBENCIFN_",",3.01,"I")
+2 ;
BILLNUM(IBENCIFN) ;GET BILL NUMBER
+1 NEW BILL
+2 SET BILL=$$GET1^DIQ(364.9,IBENCIFN_",",2.02)
+3 IF 'BILL
Begin DoDot:1
+4 SET BILL=$$GET1^DIQ(364.9,IBENCIFN_",",.15)
+5 SET BILL=$EXTRACT(BILL,($LENGTH(BILL)-$PIECE(VALMDFFTO("BILLNUM"),U,3))+1,$LENGTH(BILL))
End DoDot:1
+6 QUIT BILL
+7 ;
DATEASSNED(IBENCIFN) ;GET DATE ASSIGNED
+1 QUIT $$FMTE^XLFDT($$GET1^DIQ(364.9,IBENCIFN_",",3.03,"I"),"2ZD")
+2 ;
DAYSONWL(IBENCIFN) ;GET DAYS ON THE WORKLIST
+1 QUIT $$GET1^DIQ(364.9,IBENCIFN_",",.23)
+2 ;
INDICATOR(IBENCIFN) ;GET INDICATOR
+1 NEW PATNOTFOUND,STATUS,VISMARK
+2 ;1 = #364.91 - PAT NOT FOUND IS CODE 1
SET PATNOTFOUND=$DATA(^IBA(364.9,IBENCIFN,5,"B",1))
+3 SET STATUS=$$GET1^DIQ(364.9,IBENCIFN_",",.16,"I")
+4 SET VISMARK=$SELECT(PATNOTFOUND:"!",1:"")
+5 ;* = 'IN PROGRESS' ! = PAT NOT IN #200
SET VISMARK=VISMARK_$SELECT(STATUS=1:"*",1:"")
+6 QUIT $GET(VISMARK)
+7 ;
PATTYPE(IBENCIFN) ;GET PATIENT TYPE
+1 QUIT $$GET1^DIQ(364.9,IBENCIFN_",",.05,"I")
+2 ;
PREVACT(IBENCIFN) ;GET LAST PREVIOUS ACTIVITY
+1 NEW PREVACTIEN,ACTCODEIENS,ACTRTEUN,ACTERROR
+2 SET PREVACTIEN=$ORDER(^IBA(364.9,IBENCIFN,4,99999),-1)
+3 IF PREVACTIEN
Begin DoDot:1
+4 SET ACTCODEIENS=$PIECE(^IBA(364.9,IBENCIFN,4,PREVACTIEN,0),U,3)_","
+5 DO GETS^DIQ(364.92,ACTCODEIENS,".01;.02;","E","ACTRETURN","ACTERROR")
+6 SET PREVACTIVITY=$GET(ACTRETURN(364.92,ACTCODEIENS,.01,"E"))_" "_$EXTRACT($GET(ACTRETURN(364.92,ACTCODEIENS,.02,"E")),1,50)
End DoDot:1
+7 QUIT $GET(PREVACTIVITY)
+8 ;
PROVIDER(IBENCIFN) ;GET PROVIDER
+1 QUIT $$GET1^DIQ(364.9,IBENCIFN_",",.07,"I")
+2 ;
REASCODE(IBENCIFN) ;GET REASON CODE
+1 NEW REASON,REASCODE,REASIEN,REASONPTR
+2 SET REASIEN=$ORDER(^IBA(364.9,IBENCIFN,5,0))
+3 IF REASIEN
Begin DoDot:1
+4 SET REASONPTR=$PIECE($GET(^IBA(364.9,IBENCIFN,5,REASIEN,0)),U)
+5 IF REASONPTR'=""
Begin DoDot:2
+6 SET REASCODE=$$RJ^XLFSTR($PIECE($GET(^IBA(364.91,REASONPTR,0)),U),3," ")
+7 SET REASON=$PIECE($GET(^IBA(364.91,REASONPTR,0)),U,2)
End DoDot:2
+8 SET REASON=$GET(REASCODE)_" "_$GET(REASON)
End DoDot:1
+9 QUIT $GET(REASON)
+10 ;
SERVDATE(IBENCIFN) ;GET SERVICE DATE
+1 QUIT $$FMTE^XLFDT($$GET1^DIQ(364.9,IBENCIFN_",",.12,"I"),"2ZD")
+2 ;
SERVFAC(IBENCIFN) ;GET SERVICE FACILITY
+1 QUIT $$GET1^DIQ(364.9,IBENCIFN_",",.2,"I")
+2 ;
SSN(IBENCIFN) ;GET SERVICE FACILITY
+1 QUIT $EXTRACT($$GET1^DIQ(364.9,IBENCIFN_",",.11,"I"),6,9)
+2 ;
+3 ;PUBLISH CHANGE TO JUST ONE FIELD
FIELDPUBLISH(FIELD,FIELDVALUE,IBENCIFN,PUBSUCCESS) ;EP - PLACE DATA TO PUBLISH TO OTHER ACC ENCOUNTER WORK GROUP USERS INTO THEIR DATA GLOBALS
+1 ;
+2 NEW IBTOIBDA,LASTONE,LINE,JOB,SUBCRIBEGRP,X,VALMAR
+3 ;
+4 SET FIELD=$PIECE(FIELD,U)
+5 ;
+6 SET PUBSUCCESS=0
+7 SET SUBCRIBEGRP="IBACCWL"
+8 FOR
SET SUBCRIBEGRP=$ORDER(^TMP(SUBCRIBEGRP))
if SUBCRIBEGRP=""!(SUBCRIBEGRP'[("IBACCWL"))
QUIT
Begin DoDot:1
+9 SET JOB=0
+10 FOR
SET JOB=$ORDER(^TMP(SUBCRIBEGRP,JOB))
if 'JOB
QUIT
Begin DoDot:2
+11 ;
+12 ;DO NOT ASSIGN TO SELF
if JOB=$JOB
QUIT
+13 ;
+14 ;DEAL WITH THAT ONE VERY LOW POSSIBLE SITUATION A S LASTONEPUBLISHED=1
IF $GET(^TMP(SUBCRIBEGRP,JOB,2,0))[("NO DATA FOUND")
KILL ^TMP(SUBCRIBEGRP,JOB)
QUIT
+15 ;
+16 ;=348
if '$DATA(^TMP(SUBCRIBEGRP,$JOB,"IEN3649",IBENCIFN))
QUIT
+17 ;
+18 ;UPDATE ENTRY IN WORKLIST
+19 SET IBTOIBDA=$GET(^TMP(SUBCRIBEGRP,JOB,"IEN3649",IBENCIFN))
+20 ;TPF;IB*2*770v9;EBILL-4482 IF THIS NODE IS NOT THERE IT IS A CORRUPT REC. OR WAS DELETED BEFORE THIS PUBLISH OCCURED
if IBTOIBDA=""
QUIT
+21 SET VALMAR="^TMP("""_SUBCRIBEGRP_""","_JOB_")"
+22 DO FLDTEXT^VALM10(IBTOIBDA,FIELD,FIELDVALUE)
End DoDot:2
End DoDot:1
+23 ;
+24 QUIT
+25 ;
TRANSMITTED(IBIFN) ;EP - CHECK BILL FOR TRANSMISION STATUS
+1 ;
+2 NEW STATUS
+3 ;STATUS
SET STATUS=$$GET1^DIQ(399,IBIFN_",",.13,"E")
+4 ;JWS;7/31/25;EBILL-5712;IB*2.0*770v38;added AUTHORIZED as a successful status (commercial claims until transmitted)
+5 QUIT (STATUS="REQUEST MRA")!(STATUS="PRNT/TX")!(STATUS="AUTHORIZED")
+6 ;
+7 ;CALLED BY IBACCWLAIVIEW
ASKSTATUS(REQUIRED) ;EP - ASK STATUS ONLY FOR BACTH PROCESSING
+1 ;
+2 NEW DIR,SETOFCODES,DUOUT,DTOUT,DIROUT
+3 ;WCJ;XINDEX;TEAL
NEW TARGET,MESSAGE
+4 ;
STA ;
+1 ;S SETOFCODES=$P($P($G(^DD(364.9,.16,0)),U,3),";",1,3) ;"STATUS^S^0:OPEN;1:IN PROGRESS;2:CLOSED;3:PURGED;
+2 ;WCJ;XINDEX;TEAL
DO FIELD^DID(364.9,.16,"N","POINTER","TARGET","MESSAGE")
+3 ;S SETOFCODES=TARGET("POINTER",";",1,3) ;WCJ;XINDEX;TEAL
+4 ;TPF;XINDEX;TEAL
SET SETOFCODES=$PIECE(TARGET("POINTER"),";",1,3)
+5 SET DIR(0)="S^"_SETOFCODES
+6 SET DIR("A")="BATCH STATUS"
+7 DO ^DIR
+8 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
IF (REQUIRED)
IF (X="@")
GOTO STA
+9 ;W !!,"FIELD REQUIRED!" G STA
if $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
QUIT 0
+10 SET STATUS=Y(0)
+11 QUIT STATUS
+12 ;
AVAILABLECHK(IBDA) ;EP - CHECK IF RECORD HAS BEEN REASSIGNED AND THEREFOREE UNAVAILABEL TOI THE CURRENT USER
+1 ;
+2 NEW IBENCIFN,IBDAIEN
+3 ;TPF;IB*2*770v38;EBILL-5485,5721
IF $DATA(IBFROMVALMDDF)
NEW VALMAR
SET VALMAR=$GET(IBFROMVALMDDF(1,"VALMAR"))
if VALMAR=""
QUIT
+4 SET IBDAIEN=0
+5 ;
+6 ;TPF;IB*2*770v48;EBILL-6095
IF '$ORDER(IBDA(""))
IF $GET(IBDA)
WRITE !!,"RECORD IS NO LONGER AVAILABLE."
NEW DIR
DO PAUSE^VALM1
QUIT
+7 ;
+8 FOR
SET IBDAIEN=$ORDER(IBDA(IBDAIEN))
if 'IBDAIEN
QUIT
Begin DoDot:1
+9 ;
+10 IF $DATA(@VALMAR@(IBDAIEN,"UNAVAILABLE"))
Begin DoDot:2
+11 WRITE !,"RECORD "_IBDAIEN_" IS NO LONGER AVAILABLE BECAUSE "
+12 WRITE !,$GET(@VALMAR@(IBDAIEN,"UNAVAILABLE"))
+13 ;TPF;IB*2*770v????;EBILL-9999
WRITE !,$SELECT($GET(IBDA("TOTAL"))>1:"RECORD WILL BE REMOVED FROM THE BATCH.",1:"RECORD CAN NOT BE PROCESSED!")
+14 ;REMOVE FROM BATCH
KILL IBDA(IBDAIEN)
+15 SET VALMBCK="R"
+16 ;TPF;IB*2*770v47;EBILL-6042
NEW DIR
+17 DO PAUSE^VALM1
+18 ;
End DoDot:2
+19 ;IBPARENT=0 SHOWS IT IS A "CHILD" SCREEN!
+20 ;TPF;IB*2*770v38;EBILL-5485
IF $GET(IBPARENT)=0
Begin DoDot:2
+21 ;S IBENCIFN=$G(@VALMAR@("IEN3649",1)) ;TMP("IBACCWLEE",2866858,"IEN3649",1)=683
+22 ;;TPF;IB*2*770v48;EBILL-6095
SET IBENCIFN=$GET(^TMP("IBACCWLEE",$JOB,"IEN3649",1))
End DoDot:2
+23 IF '$TEST
Begin DoDot:2
+24 SET IBENCIFN=$GET(@VALMAR@(IBDAIEN,"IEN3649",1))
End DoDot:2
+25 ;
+26 IF $$STATUS^IBACCWLUTIL1(IBENCIFN)="CLOSED"
Begin DoDot:2
+27 WRITE !,"THIS RECORD IS NO LONGER AVAILABLE BECAUSE "
+28 WRITE !,"IT HAS BEEN CLOSED!"
+29 ;TPF;IB*2*770vPURPLE;EBILL-9999
WRITE !,$SELECT($GET(IBDA("TOTAL"))>1:"RECORD WILL BE REMOVED FROM THE BATCH.",1:"RECORD CAN NOT BE PROCESSED!")
+30 ;REMOVE FROM BATCH
KILL IBDA(IBDAIEN)
+31 SET VALMBCK="R"
+32 ;TPF;IB*2*770v47;EBILL-6042
NEW DIR
+33 DO PAUSE^VALM1
+34 ;
End DoDot:2
QUIT
End DoDot:1
+35 ;
+36 IF $DATA(IBDA)=1
KILL IBDA
Begin DoDot:1
+37 WRITE !!,"THE SELECTED RECORD(S) HAVE BEEN REASSIGNED."
+38 WRITE !,"YOU CAN NO LONGER SELECT THIS RECORD!"
End DoDot:1
+39 ;TPF;IB*2*770v47;EBILL-6042
IF '$DATA(IBDA)
WRITE !,"ALL SELECTIONS HAVE BEEN REASSIGNED"
NEW DIR
DO PAUSE^VALM1
QUIT
+40 ;
+41 QUIT
+42 ;
+43 ;TPF;IB*2*770vPURPLE;EBILL-5466
NBSCREEN(IBDA) ;EP - SCREEN FOR ACTION NB WHERE THE K# IS NOT CANCELLED YET
+1 ;
+2 NEW IBBILL,IBIFN,IBENCIFN,IBDAIEN,ORIGBTOT
+3 SET ORIGBTOT=IBDA("TOTAL")
+4 WRITE !
+5 SET IBDAIEN=0
+6 FOR
SET IBDAIEN=$ORDER(IBDA(IBDAIEN))
if 'IBDAIEN
QUIT
Begin DoDot:1
+7 ;
+8 IF $GET(IBDA(IBDAIEN))["-------------"
KILL IBDA(IBDAIEN)
SET IBDA("TOTAL")=IBDA("TOTAL")-1
QUIT
+9 ;IBPARENT=0 SHOWS IT IS A "CHILD" SCREEN!
+10 ;TPF;IB*2*770v38;EBILL-5485
IF $GET(IBPARENT)=0
Begin DoDot:2
+11 SET IBENCIFN=$GET(@VALMAR@("IEN3649",1))
End DoDot:2
+12 IF '$TEST
Begin DoDot:2
+13 SET IBENCIFN=$GET(@VALMAR@(IBDAIEN,"IEN3649",1))
End DoDot:2
+14 if '$GET(IBENCIFN)
QUIT
+15 ;
+16 SET IBIFN=$$GET1^DIQ(364.9,IBENCIFN_",",2.02,"I")
+17 if IBIFN=""
QUIT
+18 ;
+19 IF '$$CANCELLED(IBIFN)
Begin DoDot:2
+20 SET IBBILL=$$GET1^DIQ(399,IBIFN_",",.01,"E")
+21 WRITE !!,$GET(IBBILL)_" is not cancelled and cannot be closed via NB!"
+22 if (ORIGBTOT>1)
WRITE !,"Encounter has been removed from the batch."
+23 KILL IBDA(IBDAIEN)
+24 SET IBDA("TOTAL")=IBDA("TOTAL")-1
End DoDot:2
End DoDot:1
+25 ;
+26 if IBDA("TOTAL")=0!(IBDA("TOTAL")<0)
KILL IBDA("TOTAL")
+27 ;
+28 IF $DATA(IBDA)=1
KILL IBDA
Begin DoDot:1
+29 if (ORIGBTOT>1)
WRITE !!,"NO ITEMS LEFT IN THE BATCH!"
+30 ;TPF;IB*2*770v47;EBILL-6042
NEW DIR
+31 DO PAUSE^VALM1
End DoDot:1
+32 ;
+33 QUIT
CANCELLED(IBIFN) ;EP - CHECK BILL FOR CANCELLED STATUS
+1 ;
+2 NEW STATUS
+3 ;STATUS
SET STATUS=$$GET1^DIQ(399,IBIFN_",",.13,"E")
+4 QUIT (STATUS="CANCELLED")
+5 ;
+6 ;TPF;IB*2*770vPURPLE;EBILL-5715
IPSCREEN(IBDA) ;EP - SCREEN FOR ACTIVITY CODE 506 - APPLIES TO ONLY IP
+1 ;
+2 ;EBILL-5946;v42
NEW IBENCIFN,IBDAIEN,IBTYPE,IBENC,ORIGBTOT
+3 ;EBILL-5946;v42
SET ORIGBTOT=IBDA("TOTAL")
+4 WRITE !
+5 SET IBDAIEN=0
+6 FOR
SET IBDAIEN=$ORDER(IBDA(IBDAIEN))
if 'IBDAIEN
QUIT
Begin DoDot:1
+7 IF $GET(IBDA(IBDAIEN))["--------------"
KILL IBDA(IBDAIEN)
SET IBDA("TOTAL")=IBDA("TOTAL")-1
QUIT
+8 ;IBPARENT=0 SHOWS IT IS A "CHILD" SCREEN!
+9 ;TPF;IB*2*770v38;EBILL-5485
IF $GET(IBPARENT)=0
Begin DoDot:2
+10 SET IBENCIFN=$GET(@VALMAR@("IEN3649",1))
End DoDot:2
+11 IF '$TEST
Begin DoDot:2
+12 SET IBENCIFN=$GET(@VALMAR@(IBDAIEN,"IEN3649",1))
End DoDot:2
+13 ;
+14 if '$GET(IBENCIFN)
QUIT
+15 ;
+16 SET IBTYPE=$$GET1^DIQ(364.9,IBENCIFN_",",.05,"E")
+17 ;506 FOR IP IS OK
if IBTYPE="IN-PATIENT"
QUIT
+18 ;
+19 SET IBBILL=$$GET1^DIQ(364.9,IBENCIFN_",",2.02,"E")
+20 if IBBILL=""
SET IBBILL=$$GET1^DIQ(364.9,IBENCIFN_",",.15)
+21 ;
+22 WRITE !!,"Activity Code 506 is for Inpatient encounters only."
+23 ;EBILL-5946;v42
if (ORIGBTOT>1)
WRITE !,IBBILL," has been removed from the batch."
+24 KILL IBDA(IBDAIEN)
+25 SET IBDA("TOTAL")=IBDA("TOTAL")-1
End DoDot:1
+26 ;
+27 if IBDA("TOTAL")=0!(IBDA("TOTAL")<0)
KILL IBDA("TOTAL")
+28 ;
+29 IF $DATA(IBDA)=1
KILL IBDA
Begin DoDot:1
+30 ;EBILL-5946;v42
if (ORIGBTOT>1)
WRITE !,"NO ITEMS LEFT IN THE BATCH!"
+31 ;TPF;IB*2*770v47;EBILL-6042
NEW DIR
+32 DO PAUSE^VALM1
End DoDot:1
+33 ;
+34 QUIT
+35 ;
+36 ;EBILL-5130 RESEARCHING CAUSE OF <UNDEFINED>FLDTEXT+5^VALM10. CAN NOT REPLICATE
+37 ;ERROR REALLY OCCURRS IN EEPUBLISH+12^IBACCWLUTIL1 BECAUSE THE VALMAR OF PARENT WL IS GONE
+38 ;COMMENT PLACED HERE BECAUSE IBACCWLAIBILL WAS TOO BIG
EEPUBLISH(IBDAIEN,IBFROMVALMDDF,SUCCESS,LASTONEPUBLISHED) ;EP - MUST COME HERE TO PUBLISH FROM EE/RE-ASSIGN, RA-RESUBMIT
+1 ;UPDATE THE APPROPRIATE USER'S SCREEN LIST. IF CALLING FROM AN EE THEN UPDATE THE DATA ARRAY FOR THE WL THEY CALLED EE FROM
+2 ;SUCCESS IS ONLY DEFINED IN THE RA - RESUBMIT ACTION ITEM IN RESUBMITLOOP^IBACCWLAIBILL
+3 NEW VALMAR,VALMDDF
+4 SET VALMAR=$GET(IBFROMVALMDDF(1,"VALMAR"))
+5 if VALMAR=""
QUIT
+6 MERGE VALMDDF=IBFROMVALMDDF
+7 ;
+8 IF $GET(SUCCESS)
Begin DoDot:1
+9 SET @VALMAR@(IBDAIEN,"UNAVAILABLE")="RECORD HAS BEEN REASSIGNED OR RESUBMITTED. ON YOUR NEXT LOG IN YOU WILL NOT SEE THIS ENTRY."
+10 ;TPF;IB*2*770v35;EBILL-5728
if $DATA(IBFROMVALMDDF("INDICATOR"))
DO FLDTEXT^VALM10(IBDAIEN,"INDICATOR","# ")
End DoDot:1
+11 ;
+12 if $DATA(IBFROMVALMDDF("ASSIGNEDGRP"))
DO FLDTEXT^VALM10(IBDAIEN,"ASSIGNEDGRP",$GET(ASSIGNTOGRP))
+13 ;
+14 ;I '$D(^TMP("IBACCWLEE",$J,IBDAIEN,0)) Q ;TPF;EBILL-5130??? SHOULD BE ^TMP("IBACCWLFRT" OR ANY PARENT WL VALMAR IS WRONG
+15 ;TPF;IB*2*770v35;EBILL-5728
IF $GET(CURASSIGGRP)'=$$ASSIGNEDGRP^IBACCWLUTIL1(IBENCIFN)
Begin DoDot:1
+16 SET @VALMAR@(IBDAIEN,"UNAVAILABLE")="RECORD HAS BEEN REASSIGNED. ON YOUR NEXT LOG IN YOU WILL NOT SEE THIS ENTRY."
+17 if $DATA(IBFROMVALMDDF("INDICATOR"))
DO FLDTEXT^VALM10(IBDAIEN,"INDICATOR","# ")
End DoDot:1
+18 ;
+19 if $DATA(IBFROMVALMDDF("PREVACT"))
DO FLDTEXT^VALM10(IBDAIEN,"PREVACT",$GET(PREVACTIVITY))
+20 IF $DATA(IBFROMVALMDDF("PREVACT"))
SET PREVACTIVITY=$$PREVACT^IBACCWLUTIL1(IBDAIEN)
+21 ;
+22 ;UPDATE OTHER USERS IN ASSIGNED TO GROUP
if $GET(PUBLISHINGON)&($GET(ASSIGNTOGRP)'="")
DO PUBLISH^IBACCWLUTIL(ASSIGNGRP,IBENCIFN,IBDAIEN,ASSIGNTOGRP,.IBFROMVALMDDF,.PUBSUCCESS,IBDAIEN,.LASTONEPUBLISHED)
+23 ;
+24 QUIT
+25 ;
+26 ;USED BY X-REF
+27 ;W $$PTNAME^IBACCWLUTIL1(34)
PTNAME(IBENCIFN) ;EP - COMBINE NAME FIELD SIN #364.9 INTOVISTA TYPE NAME FOR NAME LOOKUP X-REF
+1 ;
+2 NEW FNAME,LNAME,MNAME
+3 SET LNAME=$PIECE($GET(^IBA(364.9,IBENCIFN,0)),U,2)
+4 SET FNAME=$PIECE($GET(^IBA(364.9,IBENCIFN,0)),U,3)
+5 SET MNAME=$PIECE($GET(^IBA(364.9,IBENCIFN,0)),U,4)
+6 if LNAME=""&(FNAME="")&(MNAME="")
QUIT "UNDEF"_U_IBENCIFN
+7 ;
+8 QUIT LNAME_","_FNAME_" "_MNAME
+9 ;
+10 ;DAYS ON WORKGROUP WORKLIST
+11 ;W $$DAYSONWRKGRP^IBACCWLUTIL1(1)
DAYSONWRKGRP(IBENCIFN) ;COMPUTE DAYS ON WORKGROUP WORKLIST
+1 ;
+2 if '$GET(IBENCIFN)
QUIT
+3 ;
+4 NEW DTASSIGNED,IENS,STATUS,STATUSDTCHANG,X,Y,X1,X2,%Y
+5 SET IENS=IBENCIFN_","
+6 ;DATE STATUS WAS CHANGED. IF STATUS=CLOSED USE AS STOP OF CLOCK
SET STATUSDTCHANG=$$GET1^DIQ(364.9,IENS,.22,"I")
+7 ;DATE ENCOUNTER ASSIGNED TO GROUP IN FIELD #3.01 ASSIGNED TO GROUP
SET DTASSIGNED=$$GET1^DIQ(364.9,IENS,3.03,"I")
+8 ;CURRENT STATUS OF THE ENCOUNTER
SET STATUS=$$GET1^DIQ(364.9,IENS,.16,"I")
+9 ;'0' FOR OPEN;
+10 ;'1' FOR IN PROGRESS;
+11 ;'2' FOR CLOSED;
+12 ;'3' FOR PURGED;
+13 ;
+14 ;2 = CLOSED THIS WILL BE USED FOR AUDIT REPORT?
IF STATUS=2
Begin DoDot:1
+15 SET X1=STATUSDTCHANG
+16 SET X2=DTASSIGNED
+17 ;X2 IS SUBTRACTED FROM X1
DO ^%DTC
+18 IF $GET(%Y)
SET DAYS=X
+19 IF '$TEST
SET DAYS="ERR"
End DoDot:1
+20 IF '$TEST
Begin DoDot:1
+21 SET X1=DT
+22 SET X2=DTASSIGNED
+23 DO ^%DTC
+24 IF $GET(%Y)
SET DAYS=X
+25 IF '$TEST
SET DAYS="ERR"
End DoDot:1
+26 ;
+27 QUIT DAYS
+28 ;
+29 ;;TPF*IB*2*770v20;EBILL=4462,4928 ADD SECONDARY DX
CONVERT2DEC(SECONDX,EEDXDISPLAY) ;EP - CONVERT SECONDARY DX STRING IN FIELD .3 FILE #364.9 TO READABLE DECIMAL
+1 ;
+2 ;TPF;IB*2*770V20 ;TPF*IB*2*770v20;EBILL=4928 DEAL WITH NULL DX PASSED
if $GET(SECONDX)?." "
QUIT ""
+3 NEW LENGTH,PIECE,RETDX,SECDX
+4 SET RETDX=""
+5 SET LENGTH=$LENGTH(SECONDX,",")-1
+6 FOR PIECE=1:1
SET SECDX=$PIECE(SECONDX,",",PIECE)
if SECDX=""
QUIT
Begin DoDot:1
+7 IF PIECE'=LENGTH
SET RETDX=RETDX_$$ICDLKUP(SECDX)_", "
+8 SET EEDXDISPLAY(PIECE)=$$ICDLKUP(SECDX)
+9 IF '$TEST
SET RETDX=RETDX_$PIECE($$ICDLKUP(SECDX)," ")
End DoDot:1
+10 ;
+11 QUIT RETDX
+12 ;TPF;IB*2*770v18;EBILL-4623 PROVIDED BY TIM Z. BUT MODIFIED
+13 ;W $$ICDLKUP^IBACCWLUTIL1("J329")
+14 ;TAZ;IB*2*770v19;EBILL-4938
ICDLKUP(IC) ;Look up the ICD Code desciption v12
+1 ;
+2 ;TPF;IB*2*770V20 ;TPF*IB*2*770v20;EBILL=4928 DEAL WITH NULL DX PASSED
if $GET(IC)?." "
QUIT ""
+3 NEW ICDARY,DESC
+4 ;TPF XINDEX
NEW RSLT
+5 SET IC=$EXTRACT(IC,1,3)_"."_$EXTRACT(IC,4,$LENGTH(IC))
+6 ;ICR #5681 (Supported)
SET RSLT=$$DIAGSRCH^LEX10CS(IC,.ICDARY)
+7 SET DESC=""
Begin DoDot:1
+8 IF RSLT<0
SET DESC="Unknown Code"
QUIT
+9 IF $GET(ICDARY(1,"IDS"))]""
SET DESC=ICDARY(1,"IDS")
QUIT
+10 IF $GET(ICDARY(1,"LEX"))]""
SET DESC=ICDARY(1,"LEX")
QUIT
+11 IF $GET(ICDARY(1,"MENU"))]""
SET DESC=ICDARY(1,"MENU")
QUIT
+12 SET DESC="Unknown Code"
End DoDot:1
ICDLKUPQ ;Exit lookup
+1 QUIT IC_" - "_DESC
+2 ;
+3 ;
HCPCSMANY(CODES,EDXDISPLAY) ;
+1 if $GET(CODES)=""
QUIT
+2 NEW PIECE,LENGTH
+3 FOR PIECE=1:1
SET CODE=$PIECE(CODES,",",PIECE)
if CODE=""
QUIT
Begin DoDot:1
+4 SET EDXDISPLAY(PIECE)=$$HCPCS(CODE)
End DoDot:1
+5 QUIT
+6 ;TPF;IB*2*770v18;EBILL-4623 PROVIDED BY TIM Z. BUT MODIFIED
HCPCS(CODE) ;CPT Code lookup
+1 NEW CPTARY,RSLT
+2 ;ICR #1995 (Supported)
SET RSLT=$$CPT^ICPTCOD(CODE,.CPTARY)
+3 IF RSLT'[""
SET CODE=CODE_" - Unknown Code"
QUIT CODE
+4 SET CODE=CODE_" - "_$PIECE(RSLT,U,3)
+5 QUIT CODE
+6 ;
+7 ;and the modifier:
+8 ;TPF;IB*2*770v18;EBILL-4623 PROVIDED BY TIM Z. BUT MODIFIED
CPTMOD(CODE) ;CPT Code Modifier lookup v12
+1 NEW CPTARY,RSLT
+2 ;ICR #1996 (Supported)
SET RSLT=$$MOD^ICPTMOD(CODE,.CPTARY)
+3 IF RSLT'[""
SET CODE=CODE_" - Unknown Code"
QUIT CODE
+4 SET CODE=CODE_" - "_$PIECE(RSLT,U,3)
+5 QUIT CODE
+6 ;
+7 ;TPF;IB*2*770v26;EBILL-5242
+8 ;S DFN=2 W $$ISSPECAUTH^IBACCWLUTIL1(DFN)
ISSPECAUTH(IBPATIEN) ;EP - RETURN Y/N FOR SPECIAL AUTHORITY
+1 ;TPF XINDEX
NEW IBRESLT,SA,SC
+2 DO CL^IBACV(IBPATIEN,,,.IBRESLT)
+3 SET (SC,SA)=" "
+4 IF $DATA(IBRESLT(1))
SET SA="Y"
+5 IF $DATA(IBRESLT(2))
SET SA="Y"
+6 ;"SERVICE CONNECTED"
IF $DATA(IBRESLT(3))
SET SC="Y"
+7 IF $DATA(IBRESLT(4))
SET SA="Y"
+8 IF $DATA(IBRESLT(5))
SET SA="Y"
+9 IF $DATA(IBRESLT(6))
SET SA="Y"
+10 IF $DATA(IBRESLT(7))
SET SA="Y"
+11 IF $DATA(IBRESLT(8))
SET SA="Y"
+12 ;
+13 SET RET=" "_SC_"/"_SA
+14 QUIT RET
