IBACCWLUTIL ;EDE/TPF - ACC (Automated Community Care) Encounters utility APIs ; 12-SEP-2023
;;2.0;INTERATED BILLING;**770**;21-MAR-2024;Build 119
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to ^ORD(101) in ICR #1372 (Pending)
; Reference to XMB(3.8,B, in ICR #3359 (Pending)
;
Q
;
;CALLED BY IBACCWLAINONBIL,IBACCWLAINOTLEG,IBACCWLAIREAS,IBACCWLAISERVCON,IBACCWLAIVIEW
EDITSTATUS(ENCIEN,STATUS,REQUIRED) ;EP - EDIT STATUS FIELD IN #364.9
;
;REQUIRED MEANS IT IS NEEDED FOR A ACTIVITY CODE REASSIGNMENT API. REQUIRED FOR AUDITING
;
Q:'$G(ENCIEN)
N DIR,SETOFCODES,DUOUT,DTOUT,DIROUT
N TARGET,MESSAGE ;WCJ;XINDEX;TEAL
;
STA ;REPEAT- STATUS REQUIRED
;
;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)="SO^"_SETOFCODES
S DIR("B")=$G(STATUS)
S DIR("A")="STATUS"
D ^DIR
I $D(DUOUT)!$D(DTOUT)!$D(DIROUT),(REQUIRED) G STA
Q:$D(DUOUT)!$D(DTOUT)!$D(DIROUT) ;W !!,"FIELD REQUIRED!" G STA
S STATUS=Y(0)
;
N DIE,DA,DR,NOW,Y
S DIE="^IBA(364.9,"
S DA=ENCIEN
S DR=".16///"_STATUS_";.22///NOW"
D ^DIE
;
Q
;
;D UPDSTATUS^IBACCWLUTIL(1,"OPEN")
;'0' FOR OPEN;
;'1' FOR IN PROGRESS;
;'2' FOR CLOSED;
;CALLED FROM EDITPREVACT^IBACCWLAINONBIL,IBACCWLAINOTLEG,IBACCWLAIREAS,IBACCWLAISERVCON
UPDSTATUS(ENCIEN,STATUS) ;EP - UPDATE STATUS IN 364.9
;
;ENCIEN = ENCOUNTER IEN
Q:'$G(ENCIEN)!(STATUS="")
N ADDFDA,ADDERROR
S ENCIENS=ENCIEN_","
S ADDFDA(364.9,ENCIENS,.16)=$G(STATUS)
S ADDFDA(364.9,ENCIENS,.22)="NOW"
D FILE^DIE("ET","ADDFDA","ADDERROR")
;
I $D(ADDERROR) D Q
.W !,"Problem occurred adding Assigned Group to Encounter. Report to eBilling"
.W !,$G(ADDERROR("DIERR",1,"TEXT",1))
.N DIR,DIRUT,DUOUT,DTOUT
.D PAUSE^VALM1
W !,"STATUS UPDATED TO: "_$G(STATUS)
;
Q
;
;CALLED FROM IBACCWLAIBILL
;W $$CHKSTATUS^IBACCWLUTIL(ENCIEN)
CHKSTATUS(ENCIEN) ;EP - RETURN EXTERNAL STATUS VALUE
N CURASSIGGRP,STATUS
S CURASSIGGRP=$$GET1^DIQ(364.9,ENCIEN_",",3.01)
S STATUS=$$GET1^DIQ(364.9,ENCIEN_",",.16) ;STATUS
Q STATUS_" ASSIGNED TO: "_CURASSIGGRP
;
;CALLED FROM EDITPREVACT^IBACCWLAINONBIL,IBACCWLAINOTLEG,IBACCWLAIREAS,IBACCWLAISERVCON
EDITAS2GRP(GRPIEN,ASSIGNTOGRP) ;EP - EDIT 'ASSIGNED TO GROUP'
;
Q:'$G(GRPIEN)!$G(ASSIGNTOGRP)=""
N DIE,DA,DR,Y
S DIC("S")="I Y'=""HIMS""" ;TPF;IB*2*770V6 DECTIVATE HIMS
S DIE="^IBA(364.9,"
S DA=GRPIEN
S DR="3.01;3.03///NOW"
D ^DIE
;
Q
;
GRPSETOFCODES(ASSIGNGRP,ACTCODEIEN,ACTGRPIEN) ;EP - RETURN SET OF CODES BASED ON ENTRY IN ASSIGN TO GROUP MULTIPLE
;
N SETOFCODES
S SETOFCODES=""
S CODE=""
F S CODE=$O(^IBA(364.92,ACTCODEIEN,5,ACTGRPIEN,5,"B",CODE)) Q:CODE="" D
.Q:CODE=ASSIGNGRP
.I CODE="BILL" S SETOFCODES=$G(SETOFCODES)_"BILL:BILLING;"
.I CODE="FRT" S SETOFCODES=$G(SETOFCODES)_"FRT:FACILITY REVENUE TECHNICIANS;"
.I CODE="PTF" S SETOFCODES=$G(SETOFCODES)_"PTF:FACILITY REVENUE PTF;" ;TPF;IB*2*770v12;EBILL-4550
.I CODE="IV" S SETOFCODES=$G(SETOFCODES)_"IV:INSURANCE VERIFICATION;"
.I CODE="RUR" S SETOFCODES=$G(SETOFCODES)_"RUR:REVENUE UTILIZATION REVIEW;"
;
Q SETOFCODES
;
;CALLED FROM EDITPREVACT^IBACCWLAINONBIL,IBACCWLAINOTLEG,IBACCWLAIREAS,IBACCWLAISERVCON
;D UPDAS2GRP^IBACCWLUTIL(1,"FRT",1)
UPDAS2GRP(ENCIEN,GROUP,DISPLAY) ;EP - UPDATE 'ASSIGNED TO GROUP' IN 364.9
N ADDFDA,ADDERROR
Q:'$G(ENCIEN)!($G(GROUP)="")
S ENCIENS=ENCIEN_","
S ADDFDA(364.9,ENCIENS,3.01)=$G(GROUP)
S ADDFDA(364.9,ENCIENS,3.03)="NOW"
D FILE^DIE("ET","ADDFDA","ADDERROR")
;
I $D(ADDERROR) D Q
.W !,"Problem occurred adding Assigned Group to Encounter. Report to eBilling"
.W !,$G(ADDERROR("DIERR",1,"TEXT",1))
.N DIR,DIRUT,DUOUT,DTOUT
.D PAUSE^VALM1
I $G(DISPLAY) W !,"'ASSIGNED TO GROUP' UPDATED TO: "_$G(GROUP) ;TPF;IB*2*770v23;EBILL-4055,5023,5036
;
Q
;
;TRIGGERED BY EDITING #364.92515 ASSOCIATED ACTION ITEMS IN #364.92 ACTIVITY CODE
;DO NOT MOVE
ACTIONREF(DA) ;EP - SET "AC" X-REF IN #364.92
;
N ACTIONID,ACTCODE,ASSIGNGRP
S ACTIONID=$P($G(^ORD(101,X,4)),U,4)
Q:ACTIONID=""
S ACTCODE=$P($G(^IBA(364.92,DA(2),0)),U)
Q:ACTCODE=""
S ASSIGNGRP=$P($G(^IBA(364.92,DA(2),5,DA(1),0)),U)
Q:ASSIGNGRP=""
S ^IBA(364.92,"AC",ACTIONID,ASSIGNGRP,ACTCODE)=1
;
Q
;
;TRIGGERED BY EDITING #364.92515 ASSOCIATED ACTION ITEMS IN #364.92 ACTIVITY CODE
;DO NOT MOVE
KACTIONREF(DA) ;EP - KILL "AC" X-REF
;
N ACTIONID,ACTCODE,ASSIGNGRP
S ACTIONID=$P($G(^ORD(101,X,4)),U,4)
Q:ACTIONID=""
S ACTCODE=$P($G(^IBA(364.92,DA(2),0)),U)
Q:ACTCODE=""
S ASSIGNGRP=$P($G(^IBA(364.92,DA(2),5,DA(1),0)),U)
Q:ASSIGNGRP=""
K ^IBA(364.92,"AC",ACTIONID,ASSIGNGRP,ACTCODE)
;
Q
;
;TRIGGRED BY #364.9255 ASSIGNED TO GROUP IN #364.92 ACTIVITY CODE
;DO NOT MOVE
ASSIGNTOREF(DA) ;EP - CREATE "AD" X-REF IN 364.92
;
N ACTCODE,ASSIGNTOGRP,ASSIGNGRP
S ACTCODE=$P($G(^IBA(364.92,DA(2),0)),U)
Q:ACTCODE=""
S ASSIGNTOGRP=$P($G(^IBA(364.92,DA(2),5,DA(1),0)),U)
Q:ASSIGNTOGRP=""
S ASSIGNGRP=$P($G(^IBA(364.92,DA(2),5,DA(1),5,DA,0)),U)
Q:ASSIGNGRP=""
S ^IBA(364.92,"AD",ACTCODE,ASSIGNGRP,ASSIGNTOGRP)=1
;
Q
;
;DO NOT MOVE
KASSIGNTOREF(DA) ;EP - KILL "AD" X-REF
;
N ACTCODE,ASSIGNTOGRP,ASSIGNGRP
S ACTCODE=$P($G(^IBA(364.92,DA(2),0)),U)
Q:ACTCODE=""
S ASSIGNTOGRP=$P($G(^IBA(364.92,DA(2),5,DA(1),0)),U)
Q:ASSIGNTOGRP=""
S ASSIGNGRP=$P($G(^IBA(364.92,DA(2),5,DA(1),5,DA,0)),U)
Q:ASSIGNGRP=""
K ^IBA(364.92,"AD",ACTCODE,ASSIGNGRP,ASSIGNTOGRP)
;
Q
;
;CLONED FROM TIUHELP. MODIFIED FOR SAC
;HELP CODE FOR PROTOCOLS IBACC WL IBACCBILL,IBACC WL IBACCBILL EE,IBACC WL IBACCFRT,IBACC WL IBACCFRT EE,IBACC WL IBACCFRPTF,IBACC WL IBACCFRPTF EE,IBACC WL IBACCIV,IBACC WL IBACCIV EE,IBACC WL IBACCRUR,IBACC WL IBACCRUR EE,IBACC WL IBACCSUP
PROTOCOL ;EP - DISPLAYS AN EXTENDED HELP FOR ACTION TYPE PROTOCOLS
N DIRUT,DTOUT,DUOUT,IBX,VALMDDF,VALMPGE,ESC,XQORQUIT,XQORPOP
S ESC=0
S IBX=X
D FULL^VALM1
I IBX="?" D G PROTX
. D DISP^XQORM1 W !!,"Enter selection by typing the name, or abbreviation.",!,"Enter '??' for additional details.",!
. I IBX="?" W:$$STOP ""
I IBX="??" D MENU(XQORNOD) I $D(DIROUT) S (XQORQUIT,XQORPOP)=1 Q
PROTX ;
S VALMBCK="R"
Q
N IBSEQ,IBI,IBJ
D CLEAR^VALM1
;
W:$$CONTINUE "Indicator Section:"
W !!?5,"* = In progress"
W !?5,"! = Patient not in VistA"
W !?5,"# = Reassigned or successfully resubmitted - no longer available"
W !?5,"C = Closed. No longer available."
W !!
;
;ORD(101) ICR #1373 (Controlled) (Pending)
W "Valid selections are:",!
S IBI=0 F S IBI=$O(^ORD(101,+XQORNOD,10,IBI)) Q:+IBI'>0 D
. S IBJ=+$P($G(^ORD(101,+XQORNOD,10,IBI,0)),U,3) S:$D(IBSEQ(IBJ)) IBJ=IBJ+.1
. S IBSEQ(IBJ)=+$P(^ORD(101,+XQORNOD,10,IBI,0),U)
S IBI=0 F S IBI=$O(IBSEQ(IBI)) Q:+IBI'>0!$D(DIRUT) D
. I $D(^ORD(101,+IBSEQ(IBI),0)) D ITEM(+IBSEQ(IBI),1)
Q
ITEM(XQORNOD,TAB) ; Show descriptions of items
N IBI
Q:$P($G(^ORD(101,+XQORNOD,0)),U,2)']""
W:$$CONTINUE !!,?+$G(TAB),$G(IOINHI),$$UPPER($P($G(^ORD(101,+XQORNOD,0)),U,2)),$G(IOINORM),!
I $D(DIRUT) Q
S IBI=0 F S IBI=$O(^ORD(101,+XQORNOD,1,IBI)) Q:+IBI'>0!$D(DIRUT) D
. W:$$CONTINUE ?(TAB+2),$G(^ORD(101,+XQORNOD,1,IBI,0)),! Q:$D(DIRUT)
Q
;
CONTINUE() ; Pagination control
N Y
I $Y<(IOSL-2) S Y=1 G CONTX
S Y=$$STOP("",1) W:+Y @IOF,!
CONTX ;
Q Y
;
STOP(PROMPT,SCROLL) ; Call DIR at bottom of screen
N DIR,DA,X,Y
I $E(IOST)'="C" S Y="" G STOPX
I +$G(SCROLL),(IOSL>($Y+5)) F W ! Q:IOSL<($Y+6)
S DIR(0)="FO^1:1",DIR("A")=$S($G(PROMPT)]"":PROMPT,1:"Press RETURN to continue or '^' to exit")
S DIR("?")="Enter '^' to quit present action or '^^' to quit to menu"
D ^DIR I $D(DIRUT),(Y="") K DIRUT
S Y=$S(Y="^":0,Y="^^":0,$D(DTOUT):"",Y="":1,1:1_U_Y)
STOPX ;
Q Y
;
UPPER(X) ; Convert lower case X to UPPER CASE
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
;CALLED FROM IBACCWLAIREAS,IBACCWLAIBILL
PUBLISH(PUBLISHGRP,IBENCIFN,FROMIBDA,ASSIGNTOGRP,VALMDDF,PUBSUCCESS,IBDAIEN,LASTONEPUBLISHED) ;EP - PLACE DATA TO PUBLISH TO OTHER ACC ENCOUNTER WORK GROUP USERS INTO THEIR DATA GLOBALS
;
Q ;***********************DIABLE TO NEXT ITERATION DO NOT RUSH THIS BECAUSE OF HURRICANE
;Q:$G(DUZ)'=561 ;EBILL-NNNN JUST FOR TESTING RE-ESTABLISHING THIS API
N LASTONE,LINE,JOB,SUBCRIBEGRP,TARGETIBDAIEN,X
N SAMESUBCRIBEGRP,TARSUBCRIBEGRP ;TPF;IB*2*770VNNNN;EBILL-9999 ;TPF XINDEX
;
S PUBSUCCESS=0
;S SUBCRIBEGRP="IBACCWL"_ASSIGNTOGRP
S TARSUBCRIBEGRP="IBACCWL"_ASSIGNTOGRP_"" ;TPF;IB*2*770VNNNN;EBILL-NNNN
S SAMESUBCRIBEGRP="IBACCWL"_ASSIGNGRP_"" ;TPF;IB*2*770VNNNN;EBILL-NNNN
;I $D(^TMP(SUBCRIBEGRP)) D
;
F SUBCRIBEGRP=TARSUBCRIBEGRP,SAMESUBCRIBEGRP D ;TPF;IB*2*770VNNNN;EBILL-NNNN
.;
.S JOB=0
.F S JOB=$O(^TMP(SUBCRIBEGRP,JOB)) Q:'JOB D
..;
..Q:JOB=$J ;DO NOT PUBLISH TO SELF
..;
..S TARGETIBDAIEN=$G(^TMP(SUBCRIBEGRP,JOB,"IEN3649",IBENCIFN)) ;TPF;IB*2*770VNNNN;EBILL-NNNN;FIND THE IBDAIEN OF THE SAME ENCOUNTER IEN IN THE SUBSCRIBER WORKGROUP DATA ARRAY
..;Q:'TARGETIBDAIEN ;TPF;IB*2*770VNNNN;EBILL-9999 QUIT SINCE THE ENCOUNTER DOES NOT EXIST ON THE POTENTIAL SUBSCRIBER WL
..;I 'TARGETIBDAIEN,(SUBCRIBEGRP=SAMESUBCRIBEGRP) THEN ADD TO SAME GROUP WL
..;I 'TARGETIBDAIEN,(SUBCRIBEGRP'=SAMESUBCRIBEGRP) THEN ADD TO TARGET GROUP WL
..;
..;I 'TARGETIBDAIEN W !!,"NEED TO ADD API TO ADD ENCOUNTER TO TARGET WORKGROUPS! QUITING FOR NOW" Q ;TPF;IB*2*770VNNNN;EBILL-NNNN
..;
..;I $D(^TMP(SUBCRIBEGRP,JOB,TARGETIBDAIEN,"UNAVAILABLE")) Q ;PREVENT DUPES FROM SEVERAL USERS ASSIGNING TO SAME GROUP. QUIT IF ON THE LIST BUT ALREADY MARKED UNAVAILABLE
..I $G(TARGETIBDAIEN),$D(^TMP(SUBCRIBEGRP,JOB,TARGETIBDAIEN,"UNAVAILABLE")) Q ;TPF;IB*2*770VNNNN;EBILL-NNNN
..;
..;I $G(^TMP(SUBCRIBEGRP,JOB,2,0))[("NO DATA FOUND") Q ;DEAL WITH THAT ONE VERY LOW POSSIBLE SITUATION. THIS WOULD BE A USER SITTING ON A NO DATA FOUND WL
..I $G(^TMP(SUBCRIBEGRP,JOB,2,0))[("NO DATA FOUND") Q ;TPF;IB*2*770VNNNN;EBILL-NNNN
..;
..I $G(TARGETIBDAIEN) S LASTONEPUBLISHED=TARGETIBDAIEN ;THEN EXISTING ENTRY NEEDS TO BE UPDATED
..E S LASTONEPUBLISHED=$O(^TMP(SUBCRIBEGRP,JOB,"IDX",""),-1)+1 ;A NEW ENTRY NEEDS TO BE CREATED
..;
..;IF IEN3649 X-REF EXISTS THEN UPDATE THAT LINE DO NOT ADD A NEW 'LASTONE"
..;THIS TAKES CARE OF THE GROUP WE ARE ASSIGNING IT TO
..;HMMM, IF THIS IS TRUE WE DO NOT WANT TO DO ANYTHING
..;I $D(^TMP(SUBCRIBEGRP,JOB,"IEN3649",@VALMAR@(IBDAIEN,"IEN3649",1))) Q ;D;TPF;IB*2*770VNNNN;EBILL-NNNN DOES NOT MAKE SENSE. ANENTRY IN ANOTHER WL AND SAME GRP WIL NOT BE UPDATED BY THE UPDSTATUS CALL
..;
..D CONVERTDFF(IBENCIFN,.LINE,LASTONEPUBLISHED,PUBLISHGRP,ASSIGNTOGRP,$J,JOB)
..;
..S ^TMP(SUBCRIBEGRP,JOB,LASTONEPUBLISHED,0)=LINE ;LINE IS NOT THE CORRECT DATA COLUMN FORMAT UNLESS CONVERTDFF COMPLETES
..S ^TMP(SUBCRIBEGRP,JOB,LASTONEPUBLISHED,"IEN3649",1)=$G(@VALMAR@(IBDAIEN,"IEN3649",1))
..S ^TMP(SUBCRIBEGRP,JOB,LASTONEPUBLISHED,"IEN399",1)=$G(@VALMAR@(IBDAIEN,"IEN399",1))
..S ^TMP(SUBCRIBEGRP,JOB,"IDX",LASTONEPUBLISHED,LASTONEPUBLISHED)=""
..S ^TMP(SUBCRIBEGRP,JOB,"PUBLISH")="YOU HAVE A NEW ENCOUNTER ASSIGNED"
..S:$G(@VALMAR@(IBDA,"IEN3649",1)) ^TMP(SUBCRIBEGRP,JOB,"PUBLISH",@VALMAR@(IBDAIEN,"IEN3649",1))="IEN OF NEW ENCOUNTER ASSIGNED"
;
S PUBSUCCESS=1
Q
;
;EXIT ACTION FOR PROTOCOLS IBACC WL IBACCBILL,IBACC WL IBACCFRT,IBACC WL IBACCFRT EE MENU,IBACC WL IBACCFRPTF,IBACC WL IBACCFRPTF EE
;IBACC WL IBACCIV,IBACC WL IBACCIV EE MENU,IBACC WL IBACCRUR,IBACC WL IBACCRUR EE MENU,IBACC WL IBACCSU
SUBSCRIBE ;EP - PULL DATA PUBLISHED FROM OTHER ACC ENCOUNTER USERS PLACED INTO YOUR DATA GLOBAL AND REFRESH SCREEN WITH IT
;
N IEN
I $D(@VALMAR@("PUBLISH")) D
.D MSG^VALM10($G(@VALMAR@("PUBLISH"))) ;TRIED UPDATING MESSAGE BAR
.S VALMCNT=$O(@VALMAR@("IDX",""),-1) ;UPDATE THE LIST COUNT
.D RE^VALM4 ;REFRESH LIST AREA
.K @VALMAR@("PUBLISH") ;CLEAR PUBLISHED NODE
;
Q
;
;CONVERT ONE VALMDDF TO ANOTHER
;D CONVERTDFF^IBACCWLUTIL()
CONVERTDFF(IBENCIFN,TODATA,LASTONE,FROMDFF,TODFF,FROMJOB,TOJOB) ;EP - CONVERT ONE VALMDDF TO ANOTHER
;
;TODFF = THE TO VALMDFF ARRAY OF COLUMNS
;FROMDFF = THE FROM VALMDFF ARRAY OF COLUMNS
;
N FIELD,FROMCOLUMN,FROMWIDTH,FROMDATA,LISTNAME,LISTIEN,PUBTO,PUBFROM,VALMARFROM,VALMARTO
N VALMDFFTO,VALMDFFFROM
;
I '($D(TODFF)\2) D
.S LISTNAME="IBACC WL IBACC"_TODFF
.S LISTIEN=$O(^SD(409.61,"B",LISTNAME,""))
.I LISTIEN="" W !!,"'"_LISTNAME_"' LIST TEMPLATE CAN NOT BE FOUND!!" S ABORT=1 Q
.S I=0 ;SET UP COLUMN DATA ARRAY
.F S I=$O(^SD(409.61,LISTIEN,"COL",I)) Q:'I I $D(^(I,0)) S VALMDFFTO($P(^(0),U))=^(0)
;
I '($D(FROMDFF)\2) D
.S LISTNAME="IBACC WL IBACC"_FROMDFF
.S LISTIEN=$O(^SD(409.61,"B",LISTNAME,""))
.I LISTIEN="" W !!,"'"_LISTNAME_"' LIST TEMPLATE CAN NOT BE FOUND!!" S ABORT=1 Q
.S I=0 ;SET UP COLUMN DATA ARRAY
.F S I=$O(^SD(409.61,LISTIEN,"COL",I)) Q:'I I $D(^(I,0)) S VALMDFFFROM($P(^(0),U))=^(0)
;
S PUBTO="IBACCWL"_TODFF
S PUBFROM="IBACCWL"_FROMDFF
S VALMARTO="^TMP("""_PUBTO_""","_TOJOB_")"
S VALMARFROM="^TMP("""_PUBFROM_""","_$J_")"
;
S TODATA=""
S FIELD=""
F S FIELD=$O(VALMDFFFROM(FIELD)) Q:FIELD="" D
.S FROMCOLUMN=$P(VALMDFFFROM(FIELD),U,2)
.S FROMWIDTH=$P(VALMDFFFROM(FIELD),U,3)-1
.S FROMDATA=$E(@VALMARFROM@(IBDAIEN,0),FROMCOLUMN,FROMCOLUMN+FROMWIDTH)
.I FIELD="LINENUM" D
..S FROMDATA=""
..S FROMDATA=$$SETSTR^VALM1(LASTONE,FROMDATA,FROMCOLUMN,FROMCOLUMN+FROMWIDTH)
.;
.Q:'$D(VALMDFFTO(FIELD))
.S TOCOLUMN=$P(VALMDFFTO(FIELD),U,2)
.S TOWIDTH=$P(VALMDFFTO(FIELD),U,3)-1
.S $E(TODATA,TOCOLUMN,TOCOLUMN+TOWIDTH)=FROMDATA
;
D SUBDATAUPDATE^IBACCWLUTIL1(.TODATA,IBENCIFN,IBDAIEN,.VALMDFFFROM,.VALMDFFTO) ;FOR FIELDS NOT IN THE PUBLISHER'S COLUMNS BUT IN THE SUBSCRIBERS COLUMN DATA, GRAB THE DATA
;
Q
;
;S FROM=DT,TO=3240405.1200 W $$DAYSCREEN^IBACCWLUTIL(FROM,TO,60)
;USED BY PULLLIST^IBACCWL1 AS SCREEN FOR LIST^DIC CALL.
;MINIMUMN # DAYS ON THE WORKLIST PROMPT IN INIT^IBACCWLSORT IF TRUE THE RECORD IS PULLED ONTO THE WORKLIST
DAYSSCREEN(FROM,TO,MINDAYS) ;EP - DAYS ON WORKLIST SCREEN FOR SORTS
N X1,X2
Q:MINDAYS=0 1
Q:FROM=""!(TO="") 1
S X1=$P(TO,".")
S X2=$P(FROM,".")
D ^%DTC
Q -X=MINDAYS!(-X>MINDAYS)
;
;USED BY IBACCWL1 TO SET UP LOOKUP FILTER FOR LIST^DIC CALL
AUTHCHK(IBBILLER,IBIFN) ;EP - AUTHORIZED BILLER SCREEN
N AUTHORIZER
Q:'$D(IBBILLER)!($G(IBIFN)="") 0
S AUTHORIZER=$P($G(^DGCR(399,IBIFN,"S")),U,11)
Q:AUTHORIZER="" 0
Q $D(IBBILLER(AUTHORIZER))
;
;CALLED BY SETARRAY^IBACCWL1
SORTLINE(VALMDDFF,LINENUM,LINE) ;EP - CREATE A LINE TO SEPARATE THE K# SORT FORM NON K# SORT
N FIELD,TODATA,X
S LINE=""
S FIELD=""
F S FIELD=$O(VALMDDFF(FIELD)) Q:FIELD="" D
.S TODATA=""
.S FROMWIDTH=$P(VALMDDFF(FIELD),U,3)+1
.;
.I FIELD="LINENUM" S TODATA=LINENUM
.E S $P(TODATA,"-",FROMWIDTH)=""
.;
.S LINE=$$SETFLD^VALM1(TODATA,LINE,FIELD)
;
Q
;
;ADD PREVIOUS ACTIVITY AND PREVIOUS ACTIVITY COMMENTS - NO USER INTERACTION
;CALLED FROM RTN IBCE837ACC
ADDPREVACT(RETURN,IBENCIFN,DUZ,ACTCODE,ASSIGNGRP,ASSIGNTOGRP,COMMENT) ;EP - ADD PREVIOUS ACTIVITY - NO USER PROMPT
;
;RETURN
N ADDIENS,ADDFDA,ADDERR,WPIENS,WPERR
;
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(ACTCODE)
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) S RETURN="0"_U_$G(ADDERR("DIERR",1,"TEXT",1)) Q
;
S WPIENS=ADDIENS(1)_","_IBENCIFN_","
D EDITPREVACT(WPIENS,.COMMENT,.WPERR) ;EDIT PREVIOUS ACTIVITY
;
I $D(WPERR) S RETURN=WPERR Q
;
S RETURN="1^Update Successful"
;
Q
;
;CALLED FROM EDITPREVACT^IBACCWLAINONBIL,IBACCWLAINOTLEG,IBACCWLAIREAS,IBACCWLAISERVCON ;REVSTATUSLOOP^IBACCWLAIVIEW ?
;K WPERR S WPIENS="6,1,",COMMENT(1)="TEST1",COMMENT(2)="TEST2" D EDITPREVACT^IBACCWLUTIL(WPIENS,.COMMENT,.WPERR)
EDITPREVACT(WPIENS,COMMENT,WPERR) ;EP- EDIT PREVIOUS ACTIVITY
;
D WP^DIE(364.94,WPIENS,10,"","COMMENT","WPERR")
;
I $D(WPERR) D
.S RETURN="0"_U_$G(WPERR("DIERR",1,"TEXT",1))
.K WPERR
.S WPERR=RETURN
;
Q
;
;CALLED BY PULLLIST^IBACCWL1,EN^IBACCWLSEC,
;W $$ISTESTER^IBACCWLUTIL(DUZ)
ISTESTER(DUZ) ;EP - RETURN 1 IF USER IS A PART OF THE ACC CENCOUNTER TEST USER GROUP
;
N XMDUZ
;
Q:'$G(DUZ) 0
Q:$$PROD^XUPROD(1) 0
;
S Y=$$FIND1^DIC(3.8,"","X","IB EBILL TESTERS","B") ;ICR #3359 (Private) Pending
I 'Y D Q 0
.W !!,"THERE IS NO 'IB EBILL TESTERS' MAIL GROUP!!"
;
S XMDUZ=DUZ D CHK^XMA21 ;ICR #10067 (Supported)
Q $T
;
;W $$ISITME^IBACCWLUTIL(DUZ)
ISITME(DUZ) ;EP - IS IT TIM? USE ONLY IN BREAKS SO BREAKS OCCUR ONLY FOR TIM F.
Q:'$G(DUZ)
N USERNAME
S USERNAME=$P($G(^VA(200,DUZ,0)),U)
Q:USERNAME=("FRAZIER,TIM") 1
Q 0
;
;W $$MG^IBACCWLUTIL($S)
MG(BYTES) ;EP -CONVERT BYTES TOI MEGABYTES
Q BYTES/1000000
;
;W $$GG^IBACCWLUTIL($S)
GG(BYTES) ;
Q BYTES/1000000000
;
;W MG2BYTES^IBACCWLUTIL($S)
MG2BYTES(MG) ;EP -
Q MG*1000000
;
;K IBAUTH S USERGROUP="BILL" D AUTHORIZER^IBACCWLUTIL(USERGROUP,.IBAUTH)
AUTHORIZER(USERGROUP,IBAUTH) ;EP - FIND ALL AUTHORIZERS GIVEN A GROUP NAME
;
N AUTHORIZER,ENCIFN,GRP,IBIFN
K IBAUTH
S ENCIFN=0
F S ENCIFN=$O(^IBA(364.9,"AC",USERGROUP,ENCIFN)) Q:'ENCIFN D
.S IBIFN=$P($G(^IBA(364.9,ENCIFN,2)),U,2)
.Q:'IBIFN
.S AUTHORIZER=$P($G(^DGCR(399,IBIFN,"S")),U,11)
.Q:'AUTHORIZER
.S IBAUTH(AUTHORIZER)=$G(IBAUTH(AUTHORIZER))+1
Q
;
GETFLD(FIELD,LINE) ;EP - RETURN CURRENT VALUE OF A DISPLAY FIELD FROM LINE
;
Q:'$D(FIELD)!('$D(LINE)) 0
N IBDA,COLUMN,WIDTH,CURVALUE
S IBDA=$G(LINE)
S COLUMN=$P(FIELD,U,2)
S WIDTH=$P(FIELD,U,3)
S CURVALUE=$E(LINE(IBDA),COLUMN,COLUMN+(WIDTH-1))
Q CURVALUE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBACCWLUTIL 18210 printed May 25, 2026@12:10:13 Page 2
IBACCWLUTIL ;EDE/TPF - ACC (Automated Community Care) Encounters utility APIs ; 12-SEP-2023
+1 ;;2.0;INTERATED BILLING;**770**;21-MAR-2024;Build 119
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to ^ORD(101) in ICR #1372 (Pending)
+5 ; Reference to XMB(3.8,B, in ICR #3359 (Pending)
+6 ;
+7 QUIT
+8 ;
+9 ;CALLED BY IBACCWLAINONBIL,IBACCWLAINOTLEG,IBACCWLAIREAS,IBACCWLAISERVCON,IBACCWLAIVIEW
EDITSTATUS(ENCIEN,STATUS,REQUIRED) ;EP - EDIT STATUS FIELD IN #364.9
+1 ;
+2 ;REQUIRED MEANS IT IS NEEDED FOR A ACTIVITY CODE REASSIGNMENT API. REQUIRED FOR AUDITING
+3 ;
+4 if '$GET(ENCIEN)
QUIT
+5 NEW DIR,SETOFCODES,DUOUT,DTOUT,DIROUT
+6 ;WCJ;XINDEX;TEAL
NEW TARGET,MESSAGE
+7 ;
STA ;REPEAT- STATUS REQUIRED
+1 ;
+2 ;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
+3 ;WCJ;XINDEX;TEAL
DO FIELD^DID(364.9,.16,"N","POINTER","TARGET","MESSAGE")
+4 ;S SETOFCODES=TARGET("POINTER",";",1,3) ;WCJ;XINDEX;TEAL
+5 ;TPF;XINDEX;TEAL
SET SETOFCODES=$PIECE(TARGET("POINTER"),";",1,3)
+6 SET DIR(0)="SO^"_SETOFCODES
+7 SET DIR("B")=$GET(STATUS)
+8 SET DIR("A")="STATUS"
+9 DO ^DIR
+10 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
IF (REQUIRED)
GOTO STA
+11 ;W !!,"FIELD REQUIRED!" G STA
if $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
QUIT
+12 SET STATUS=Y(0)
+13 ;
+14 NEW DIE,DA,DR,NOW,Y
+15 SET DIE="^IBA(364.9,"
+16 SET DA=ENCIEN
+17 SET DR=".16///"_STATUS_";.22///NOW"
+18 DO ^DIE
+19 ;
+20 QUIT
+21 ;
+22 ;D UPDSTATUS^IBACCWLUTIL(1,"OPEN")
+23 ;'0' FOR OPEN;
+24 ;'1' FOR IN PROGRESS;
+25 ;'2' FOR CLOSED;
+26 ;CALLED FROM EDITPREVACT^IBACCWLAINONBIL,IBACCWLAINOTLEG,IBACCWLAIREAS,IBACCWLAISERVCON
UPDSTATUS(ENCIEN,STATUS) ;EP - UPDATE STATUS IN 364.9
+1 ;
+2 ;ENCIEN = ENCOUNTER IEN
+3 if '$GET(ENCIEN)!(STATUS="")
QUIT
+4 NEW ADDFDA,ADDERROR
+5 SET ENCIENS=ENCIEN_","
+6 SET ADDFDA(364.9,ENCIENS,.16)=$GET(STATUS)
+7 SET ADDFDA(364.9,ENCIENS,.22)="NOW"
+8 DO FILE^DIE("ET","ADDFDA","ADDERROR")
+9 ;
+10 IF $DATA(ADDERROR)
Begin DoDot:1
+11 WRITE !,"Problem occurred adding Assigned Group to Encounter. Report to eBilling"
+12 WRITE !,$GET(ADDERROR("DIERR",1,"TEXT",1))
+13 NEW DIR,DIRUT,DUOUT,DTOUT
+14 DO PAUSE^VALM1
End DoDot:1
QUIT
+15 WRITE !,"STATUS UPDATED TO: "_$GET(STATUS)
+16 ;
+17 QUIT
+18 ;
+19 ;CALLED FROM IBACCWLAIBILL
+20 ;W $$CHKSTATUS^IBACCWLUTIL(ENCIEN)
CHKSTATUS(ENCIEN) ;EP - RETURN EXTERNAL STATUS VALUE
+1 NEW CURASSIGGRP,STATUS
+2 SET CURASSIGGRP=$$GET1^DIQ(364.9,ENCIEN_",",3.01)
+3 ;STATUS
SET STATUS=$$GET1^DIQ(364.9,ENCIEN_",",.16)
+4 QUIT STATUS_" ASSIGNED TO: "_CURASSIGGRP
+5 ;
+6 ;CALLED FROM EDITPREVACT^IBACCWLAINONBIL,IBACCWLAINOTLEG,IBACCWLAIREAS,IBACCWLAISERVCON
EDITAS2GRP(GRPIEN,ASSIGNTOGRP) ;EP - EDIT 'ASSIGNED TO GROUP'
+1 ;
+2 if '$GET(GRPIEN)!$GET(ASSIGNTOGRP)=""
QUIT
+3 NEW DIE,DA,DR,Y
+4 ;TPF;IB*2*770V6 DECTIVATE HIMS
SET DIC("S")="I Y'=""HIMS"""
+5 SET DIE="^IBA(364.9,"
+6 SET DA=GRPIEN
+7 SET DR="3.01;3.03///NOW"
+8 DO ^DIE
+9 ;
+10 QUIT
+11 ;
GRPSETOFCODES(ASSIGNGRP,ACTCODEIEN,ACTGRPIEN) ;EP - RETURN SET OF CODES BASED ON ENTRY IN ASSIGN TO GROUP MULTIPLE
+1 ;
+2 NEW SETOFCODES
+3 SET SETOFCODES=""
+4 SET CODE=""
+5 FOR
SET CODE=$ORDER(^IBA(364.92,ACTCODEIEN,5,ACTGRPIEN,5,"B",CODE))
if CODE=""
QUIT
Begin DoDot:1
+6 if CODE=ASSIGNGRP
QUIT
+7 IF CODE="BILL"
SET SETOFCODES=$GET(SETOFCODES)_"BILL:BILLING;"
+8 IF CODE="FRT"
SET SETOFCODES=$GET(SETOFCODES)_"FRT:FACILITY REVENUE TECHNICIANS;"
+9 ;TPF;IB*2*770v12;EBILL-4550
IF CODE="PTF"
SET SETOFCODES=$GET(SETOFCODES)_"PTF:FACILITY REVENUE PTF;"
+10 IF CODE="IV"
SET SETOFCODES=$GET(SETOFCODES)_"IV:INSURANCE VERIFICATION;"
+11 IF CODE="RUR"
SET SETOFCODES=$GET(SETOFCODES)_"RUR:REVENUE UTILIZATION REVIEW;"
End DoDot:1
+12 ;
+13 QUIT SETOFCODES
+14 ;
+15 ;CALLED FROM EDITPREVACT^IBACCWLAINONBIL,IBACCWLAINOTLEG,IBACCWLAIREAS,IBACCWLAISERVCON
+16 ;D UPDAS2GRP^IBACCWLUTIL(1,"FRT",1)
UPDAS2GRP(ENCIEN,GROUP,DISPLAY) ;EP - UPDATE 'ASSIGNED TO GROUP' IN 364.9
+1 NEW ADDFDA,ADDERROR
+2 if '$GET(ENCIEN)!($GET(GROUP)="")
QUIT
+3 SET ENCIENS=ENCIEN_","
+4 SET ADDFDA(364.9,ENCIENS,3.01)=$GET(GROUP)
+5 SET ADDFDA(364.9,ENCIENS,3.03)="NOW"
+6 DO FILE^DIE("ET","ADDFDA","ADDERROR")
+7 ;
+8 IF $DATA(ADDERROR)
Begin DoDot:1
+9 WRITE !,"Problem occurred adding Assigned Group to Encounter. Report to eBilling"
+10 WRITE !,$GET(ADDERROR("DIERR",1,"TEXT",1))
+11 NEW DIR,DIRUT,DUOUT,DTOUT
+12 DO PAUSE^VALM1
End DoDot:1
QUIT
+13 ;TPF;IB*2*770v23;EBILL-4055,5023,5036
IF $GET(DISPLAY)
WRITE !,"'ASSIGNED TO GROUP' UPDATED TO: "_$GET(GROUP)
+14 ;
+15 QUIT
+16 ;
+17 ;TRIGGERED BY EDITING #364.92515 ASSOCIATED ACTION ITEMS IN #364.92 ACTIVITY CODE
+18 ;DO NOT MOVE
ACTIONREF(DA) ;EP - SET "AC" X-REF IN #364.92
+1 ;
+2 NEW ACTIONID,ACTCODE,ASSIGNGRP
+3 SET ACTIONID=$PIECE($GET(^ORD(101,X,4)),U,4)
+4 if ACTIONID=""
QUIT
+5 SET ACTCODE=$PIECE($GET(^IBA(364.92,DA(2),0)),U)
+6 if ACTCODE=""
QUIT
+7 SET ASSIGNGRP=$PIECE($GET(^IBA(364.92,DA(2),5,DA(1),0)),U)
+8 if ASSIGNGRP=""
QUIT
+9 SET ^IBA(364.92,"AC",ACTIONID,ASSIGNGRP,ACTCODE)=1
+10 ;
+11 QUIT
+12 ;
+13 ;TRIGGERED BY EDITING #364.92515 ASSOCIATED ACTION ITEMS IN #364.92 ACTIVITY CODE
+14 ;DO NOT MOVE
KACTIONREF(DA) ;EP - KILL "AC" X-REF
+1 ;
+2 NEW ACTIONID,ACTCODE,ASSIGNGRP
+3 SET ACTIONID=$PIECE($GET(^ORD(101,X,4)),U,4)
+4 if ACTIONID=""
QUIT
+5 SET ACTCODE=$PIECE($GET(^IBA(364.92,DA(2),0)),U)
+6 if ACTCODE=""
QUIT
+7 SET ASSIGNGRP=$PIECE($GET(^IBA(364.92,DA(2),5,DA(1),0)),U)
+8 if ASSIGNGRP=""
QUIT
+9 KILL ^IBA(364.92,"AC",ACTIONID,ASSIGNGRP,ACTCODE)
+10 ;
+11 QUIT
+12 ;
+13 ;TRIGGRED BY #364.9255 ASSIGNED TO GROUP IN #364.92 ACTIVITY CODE
+14 ;DO NOT MOVE
ASSIGNTOREF(DA) ;EP - CREATE "AD" X-REF IN 364.92
+1 ;
+2 NEW ACTCODE,ASSIGNTOGRP,ASSIGNGRP
+3 SET ACTCODE=$PIECE($GET(^IBA(364.92,DA(2),0)),U)
+4 if ACTCODE=""
QUIT
+5 SET ASSIGNTOGRP=$PIECE($GET(^IBA(364.92,DA(2),5,DA(1),0)),U)
+6 if ASSIGNTOGRP=""
QUIT
+7 SET ASSIGNGRP=$PIECE($GET(^IBA(364.92,DA(2),5,DA(1),5,DA,0)),U)
+8 if ASSIGNGRP=""
QUIT
+9 SET ^IBA(364.92,"AD",ACTCODE,ASSIGNGRP,ASSIGNTOGRP)=1
+10 ;
+11 QUIT
+12 ;
+13 ;DO NOT MOVE
KASSIGNTOREF(DA) ;EP - KILL "AD" X-REF
+1 ;
+2 NEW ACTCODE,ASSIGNTOGRP,ASSIGNGRP
+3 SET ACTCODE=$PIECE($GET(^IBA(364.92,DA(2),0)),U)
+4 if ACTCODE=""
QUIT
+5 SET ASSIGNTOGRP=$PIECE($GET(^IBA(364.92,DA(2),5,DA(1),0)),U)
+6 if ASSIGNTOGRP=""
QUIT
+7 SET ASSIGNGRP=$PIECE($GET(^IBA(364.92,DA(2),5,DA(1),5,DA,0)),U)
+8 if ASSIGNGRP=""
QUIT
+9 KILL ^IBA(364.92,"AD",ACTCODE,ASSIGNGRP,ASSIGNTOGRP)
+10 ;
+11 QUIT
+12 ;
+13 ;CLONED FROM TIUHELP. MODIFIED FOR SAC
+14 ;HELP CODE FOR PROTOCOLS IBACC WL IBACCBILL,IBACC WL IBACCBILL EE,IBACC WL IBACCFRT,IBACC WL IBACCFRT EE,IBACC WL IBACCFRPTF,IBACC WL IBACCFRPTF EE,IBACC WL IBACCIV,IBACC WL IBACCIV EE,IBACC WL IBACCRUR,IBACC WL IBACCRUR EE,IBACC WL IBACCSUP
PROTOCOL ;EP - DISPLAYS AN EXTENDED HELP FOR ACTION TYPE PROTOCOLS
+1 NEW DIRUT,DTOUT,DUOUT,IBX,VALMDDF,VALMPGE,ESC,XQORQUIT,XQORPOP
+2 SET ESC=0
+3 SET IBX=X
+4 DO FULL^VALM1
+5 IF IBX="?"
Begin DoDot:1
+6 DO DISP^XQORM1
WRITE !!,"Enter selection by typing the name, or abbreviation.",!,"Enter '??' for additional details.",!
+7 IF IBX="?"
if $$STOP
WRITE ""
End DoDot:1
GOTO PROTX
+8 IF IBX="??"
DO MENU(XQORNOD)
IF $DATA(DIROUT)
SET (XQORQUIT,XQORPOP)=1
QUIT
PROTX ;
+1 SET VALMBCK="R"
+2 QUIT
+1 NEW IBSEQ,IBI,IBJ
+2 DO CLEAR^VALM1
+3 ;
+4 if $$CONTINUE
WRITE "Indicator Section:"
+5 WRITE !!?5,"* = In progress"
+6 WRITE !?5,"! = Patient not in VistA"
+7 WRITE !?5,"# = Reassigned or successfully resubmitted - no longer available"
+8 WRITE !?5,"C = Closed. No longer available."
+9 WRITE !!
+10 ;
+11 ;ORD(101) ICR #1373 (Controlled) (Pending)
+12 WRITE "Valid selections are:",!
+13 SET IBI=0
FOR
SET IBI=$ORDER(^ORD(101,+XQORNOD,10,IBI))
if +IBI'>0
QUIT
Begin DoDot:1
+14 SET IBJ=+$PIECE($GET(^ORD(101,+XQORNOD,10,IBI,0)),U,3)
if $DATA(IBSEQ(IBJ))
SET IBJ=IBJ+.1
+15 SET IBSEQ(IBJ)=+$PIECE(^ORD(101,+XQORNOD,10,IBI,0),U)
End DoDot:1
+16 SET IBI=0
FOR
SET IBI=$ORDER(IBSEQ(IBI))
if +IBI'>0!$DATA(DIRUT)
QUIT
Begin DoDot:1
+17 IF $DATA(^ORD(101,+IBSEQ(IBI),0))
DO ITEM(+IBSEQ(IBI),1)
End DoDot:1
+18 QUIT
ITEM(XQORNOD,TAB) ; Show descriptions of items
+1 NEW IBI
+2 if $PIECE($GET(^ORD(101,+XQORNOD,0)),U,2)']""
QUIT
+3 if $$CONTINUE
WRITE !!,?+$GET(TAB),$GET(IOINHI),$$UPPER($PIECE($GET(^ORD(101,+XQORNOD,0)),U,2)),$GET(IOINORM),!
+4 IF $DATA(DIRUT)
QUIT
+5 SET IBI=0
FOR
SET IBI=$ORDER(^ORD(101,+XQORNOD,1,IBI))
if +IBI'>0!$DATA(DIRUT)
QUIT
Begin DoDot:1
+6 if $$CONTINUE
WRITE ?(TAB+2),$GET(^ORD(101,+XQORNOD,1,IBI,0)),!
if $DATA(DIRUT)
QUIT
End DoDot:1
+7 QUIT
+8 ;
CONTINUE() ; Pagination control
+1 NEW Y
+2 IF $Y<(IOSL-2)
SET Y=1
GOTO CONTX
+3 SET Y=$$STOP("",1)
if +Y
WRITE @IOF,!
CONTX ;
+1 QUIT Y
+2 ;
STOP(PROMPT,SCROLL) ; Call DIR at bottom of screen
+1 NEW DIR,DA,X,Y
+2 IF $EXTRACT(IOST)'="C"
SET Y=""
GOTO STOPX
+3 IF +$GET(SCROLL)
IF (IOSL>($Y+5))
FOR
WRITE !
if IOSL<($Y+6)
QUIT
+4 SET DIR(0)="FO^1:1"
SET DIR("A")=$SELECT($GET(PROMPT)]"":PROMPT,1:"Press RETURN to continue or '^' to exit")
+5 SET DIR("?")="Enter '^' to quit present action or '^^' to quit to menu"
+6 DO ^DIR
IF $DATA(DIRUT)
IF (Y="")
KILL DIRUT
+7 SET Y=$SELECT(Y="^":0,Y="^^":0,$DATA(DTOUT):"",Y="":1,1:1_U_Y)
STOPX ;
+1 QUIT Y
+2 ;
UPPER(X) ; Convert lower case X to UPPER CASE
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ;
+3 ;CALLED FROM IBACCWLAIREAS,IBACCWLAIBILL
PUBLISH(PUBLISHGRP,IBENCIFN,FROMIBDA,ASSIGNTOGRP,VALMDDF,PUBSUCCESS,IBDAIEN,LASTONEPUBLISHED) ;EP - PLACE DATA TO PUBLISH TO OTHER ACC ENCOUNTER WORK GROUP USERS INTO THEIR DATA GLOBALS
+1 ;
+2 ;***********************DIABLE TO NEXT ITERATION DO NOT RUSH THIS BECAUSE OF HURRICANE
QUIT
+3 ;Q:$G(DUZ)'=561 ;EBILL-NNNN JUST FOR TESTING RE-ESTABLISHING THIS API
+4 NEW LASTONE,LINE,JOB,SUBCRIBEGRP,TARGETIBDAIEN,X
+5 ;TPF;IB*2*770VNNNN;EBILL-9999 ;TPF XINDEX
NEW SAMESUBCRIBEGRP,TARSUBCRIBEGRP
+6 ;
+7 SET PUBSUCCESS=0
+8 ;S SUBCRIBEGRP="IBACCWL"_ASSIGNTOGRP
+9 ;TPF;IB*2*770VNNNN;EBILL-NNNN
SET TARSUBCRIBEGRP="IBACCWL"_ASSIGNTOGRP_""
+10 ;TPF;IB*2*770VNNNN;EBILL-NNNN
SET SAMESUBCRIBEGRP="IBACCWL"_ASSIGNGRP_""
+11 ;I $D(^TMP(SUBCRIBEGRP)) D
+12 ;
+13 ;TPF;IB*2*770VNNNN;EBILL-NNNN
FOR SUBCRIBEGRP=TARSUBCRIBEGRP,SAMESUBCRIBEGRP
Begin DoDot:1
+14 ;
+15 SET JOB=0
+16 FOR
SET JOB=$ORDER(^TMP(SUBCRIBEGRP,JOB))
if 'JOB
QUIT
Begin DoDot:2
+17 ;
+18 ;DO NOT PUBLISH TO SELF
if JOB=$JOB
QUIT
+19 ;
+20 ;TPF;IB*2*770VNNNN;EBILL-NNNN;FIND THE IBDAIEN OF THE SAME ENCOUNTER IEN IN THE SUBSCRIBER WORKGROUP DATA ARRAY
SET TARGETIBDAIEN=$GET(^TMP(SUBCRIBEGRP,JOB,"IEN3649",IBENCIFN))
+21 ;Q:'TARGETIBDAIEN ;TPF;IB*2*770VNNNN;EBILL-9999 QUIT SINCE THE ENCOUNTER DOES NOT EXIST ON THE POTENTIAL SUBSCRIBER WL
+22 ;I 'TARGETIBDAIEN,(SUBCRIBEGRP=SAMESUBCRIBEGRP) THEN ADD TO SAME GROUP WL
+23 ;I 'TARGETIBDAIEN,(SUBCRIBEGRP'=SAMESUBCRIBEGRP) THEN ADD TO TARGET GROUP WL
+24 ;
+25 ;I 'TARGETIBDAIEN W !!,"NEED TO ADD API TO ADD ENCOUNTER TO TARGET WORKGROUPS! QUITING FOR NOW" Q ;TPF;IB*2*770VNNNN;EBILL-NNNN
+26 ;
+27 ;I $D(^TMP(SUBCRIBEGRP,JOB,TARGETIBDAIEN,"UNAVAILABLE")) Q ;PREVENT DUPES FROM SEVERAL USERS ASSIGNING TO SAME GROUP. QUIT IF ON THE LIST BUT ALREADY MARKED UNAVAILABLE
+28 ;TPF;IB*2*770VNNNN;EBILL-NNNN
IF $GET(TARGETIBDAIEN)
IF $DATA(^TMP(SUBCRIBEGRP,JOB,TARGETIBDAIEN,"UNAVAILABLE"))
QUIT
+29 ;
+30 ;I $G(^TMP(SUBCRIBEGRP,JOB,2,0))[("NO DATA FOUND") Q ;DEAL WITH THAT ONE VERY LOW POSSIBLE SITUATION. THIS WOULD BE A USER SITTING ON A NO DATA FOUND WL
+31 ;TPF;IB*2*770VNNNN;EBILL-NNNN
IF $GET(^TMP(SUBCRIBEGRP,JOB,2,0))[("NO DATA FOUND")
QUIT
+32 ;
+33 ;THEN EXISTING ENTRY NEEDS TO BE UPDATED
IF $GET(TARGETIBDAIEN)
SET LASTONEPUBLISHED=TARGETIBDAIEN
+34 ;A NEW ENTRY NEEDS TO BE CREATED
IF '$TEST
SET LASTONEPUBLISHED=$ORDER(^TMP(SUBCRIBEGRP,JOB,"IDX",""),-1)+1
+35 ;
+36 ;IF IEN3649 X-REF EXISTS THEN UPDATE THAT LINE DO NOT ADD A NEW 'LASTONE"
+37 ;THIS TAKES CARE OF THE GROUP WE ARE ASSIGNING IT TO
+38 ;HMMM, IF THIS IS TRUE WE DO NOT WANT TO DO ANYTHING
+39 ;I $D(^TMP(SUBCRIBEGRP,JOB,"IEN3649",@VALMAR@(IBDAIEN,"IEN3649",1))) Q ;D;TPF;IB*2*770VNNNN;EBILL-NNNN DOES NOT MAKE SENSE. ANENTRY IN ANOTHER WL AND SAME GRP WIL NOT BE UPDATED BY THE UPDSTATUS CALL
+40 ;
+41 DO CONVERTDFF(IBENCIFN,.LINE,LASTONEPUBLISHED,PUBLISHGRP,ASSIGNTOGRP,$JOB,JOB)
+42 ;
+43 ;LINE IS NOT THE CORRECT DATA COLUMN FORMAT UNLESS CONVERTDFF COMPLETES
SET ^TMP(SUBCRIBEGRP,JOB,LASTONEPUBLISHED,0)=LINE
+44 SET ^TMP(SUBCRIBEGRP,JOB,LASTONEPUBLISHED,"IEN3649",1)=$GET(@VALMAR@(IBDAIEN,"IEN3649",1))
+45 SET ^TMP(SUBCRIBEGRP,JOB,LASTONEPUBLISHED,"IEN399",1)=$GET(@VALMAR@(IBDAIEN,"IEN399",1))
+46 SET ^TMP(SUBCRIBEGRP,JOB,"IDX",LASTONEPUBLISHED,LASTONEPUBLISHED)=""
+47 SET ^TMP(SUBCRIBEGRP,JOB,"PUBLISH")="YOU HAVE A NEW ENCOUNTER ASSIGNED"
+48 if $GET(@VALMAR@(IBDA,"IEN3649",1))
SET ^TMP(SUBCRIBEGRP,JOB,"PUBLISH",@VALMAR@(IBDAIEN,"IEN3649",1))="IEN OF NEW ENCOUNTER ASSIGNED"
End DoDot:2
End DoDot:1
+49 ;
+50 SET PUBSUCCESS=1
+51 QUIT
+52 ;
+53 ;EXIT ACTION FOR PROTOCOLS IBACC WL IBACCBILL,IBACC WL IBACCFRT,IBACC WL IBACCFRT EE MENU,IBACC WL IBACCFRPTF,IBACC WL IBACCFRPTF EE
+54 ;IBACC WL IBACCIV,IBACC WL IBACCIV EE MENU,IBACC WL IBACCRUR,IBACC WL IBACCRUR EE MENU,IBACC WL IBACCSU
SUBSCRIBE ;EP - PULL DATA PUBLISHED FROM OTHER ACC ENCOUNTER USERS PLACED INTO YOUR DATA GLOBAL AND REFRESH SCREEN WITH IT
+1 ;
+2 NEW IEN
+3 IF $DATA(@VALMAR@("PUBLISH"))
Begin DoDot:1
+4 ;TRIED UPDATING MESSAGE BAR
DO MSG^VALM10($GET(@VALMAR@("PUBLISH")))
+5 ;UPDATE THE LIST COUNT
SET VALMCNT=$ORDER(@VALMAR@("IDX",""),-1)
+6 ;REFRESH LIST AREA
DO RE^VALM4
+7 ;CLEAR PUBLISHED NODE
KILL @VALMAR@("PUBLISH")
End DoDot:1
+8 ;
+9 QUIT
+10 ;
+11 ;CONVERT ONE VALMDDF TO ANOTHER
+12 ;D CONVERTDFF^IBACCWLUTIL()
CONVERTDFF(IBENCIFN,TODATA,LASTONE,FROMDFF,TODFF,FROMJOB,TOJOB) ;EP - CONVERT ONE VALMDDF TO ANOTHER
+1 ;
+2 ;TODFF = THE TO VALMDFF ARRAY OF COLUMNS
+3 ;FROMDFF = THE FROM VALMDFF ARRAY OF COLUMNS
+4 ;
+5 NEW FIELD,FROMCOLUMN,FROMWIDTH,FROMDATA,LISTNAME,LISTIEN,PUBTO,PUBFROM,VALMARFROM,VALMARTO
+6 NEW VALMDFFTO,VALMDFFFROM
+7 ;
+8 IF '($DATA(TODFF)\2)
Begin DoDot:1
+9 SET LISTNAME="IBACC WL IBACC"_TODFF
+10 SET LISTIEN=$ORDER(^SD(409.61,"B",LISTNAME,""))
+11 IF LISTIEN=""
WRITE !!,"'"_LISTNAME_"' LIST TEMPLATE CAN NOT BE FOUND!!"
SET ABORT=1
QUIT
+12 ;SET UP COLUMN DATA ARRAY
SET I=0
+13 FOR
SET I=$ORDER(^SD(409.61,LISTIEN,"COL",I))
if 'I
QUIT
IF $DATA(^(I,0))
SET VALMDFFTO($PIECE(^(0),U))=^(0)
End DoDot:1
+14 ;
+15 IF '($DATA(FROMDFF)\2)
Begin DoDot:1
+16 SET LISTNAME="IBACC WL IBACC"_FROMDFF
+17 SET LISTIEN=$ORDER(^SD(409.61,"B",LISTNAME,""))
+18 IF LISTIEN=""
WRITE !!,"'"_LISTNAME_"' LIST TEMPLATE CAN NOT BE FOUND!!"
SET ABORT=1
QUIT
+19 ;SET UP COLUMN DATA ARRAY
SET I=0
+20 FOR
SET I=$ORDER(^SD(409.61,LISTIEN,"COL",I))
if 'I
QUIT
IF $DATA(^(I,0))
SET VALMDFFFROM($PIECE(^(0),U))=^(0)
End DoDot:1
+21 ;
+22 SET PUBTO="IBACCWL"_TODFF
+23 SET PUBFROM="IBACCWL"_FROMDFF
+24 SET VALMARTO="^TMP("""_PUBTO_""","_TOJOB_")"
+25 SET VALMARFROM="^TMP("""_PUBFROM_""","_$JOB_")"
+26 ;
+27 SET TODATA=""
+28 SET FIELD=""
+29 FOR
SET FIELD=$ORDER(VALMDFFFROM(FIELD))
if FIELD=""
QUIT
Begin DoDot:1
+30 SET FROMCOLUMN=$PIECE(VALMDFFFROM(FIELD),U,2)
+31 SET FROMWIDTH=$PIECE(VALMDFFFROM(FIELD),U,3)-1
+32 SET FROMDATA=$EXTRACT(@VALMARFROM@(IBDAIEN,0),FROMCOLUMN,FROMCOLUMN+FROMWIDTH)
+33 IF FIELD="LINENUM"
Begin DoDot:2
+34 SET FROMDATA=""
+35 SET FROMDATA=$$SETSTR^VALM1(LASTONE,FROMDATA,FROMCOLUMN,FROMCOLUMN+FROMWIDTH)
End DoDot:2
+36 ;
+37 if '$DATA(VALMDFFTO(FIELD))
QUIT
+38 SET TOCOLUMN=$PIECE(VALMDFFTO(FIELD),U,2)
+39 SET TOWIDTH=$PIECE(VALMDFFTO(FIELD),U,3)-1
+40 SET $EXTRACT(TODATA,TOCOLUMN,TOCOLUMN+TOWIDTH)=FROMDATA
End DoDot:1
+41 ;
+42 ;FOR FIELDS NOT IN THE PUBLISHER'S COLUMNS BUT IN THE SUBSCRIBERS COLUMN DATA, GRAB THE DATA
DO SUBDATAUPDATE^IBACCWLUTIL1(.TODATA,IBENCIFN,IBDAIEN,.VALMDFFFROM,.VALMDFFTO)
+43 ;
+44 QUIT
+45 ;
+46 ;S FROM=DT,TO=3240405.1200 W $$DAYSCREEN^IBACCWLUTIL(FROM,TO,60)
+47 ;USED BY PULLLIST^IBACCWL1 AS SCREEN FOR LIST^DIC CALL.
+48 ;MINIMUMN # DAYS ON THE WORKLIST PROMPT IN INIT^IBACCWLSORT IF TRUE THE RECORD IS PULLED ONTO THE WORKLIST
DAYSSCREEN(FROM,TO,MINDAYS) ;EP - DAYS ON WORKLIST SCREEN FOR SORTS
+1 NEW X1,X2
+2 if MINDAYS=0
QUIT 1
+3 if FROM=""!(TO="")
QUIT 1
+4 SET X1=$PIECE(TO,".")
+5 SET X2=$PIECE(FROM,".")
+6 DO ^%DTC
+7 QUIT -X=MINDAYS!(-X>MINDAYS)
+8 ;
+9 ;USED BY IBACCWL1 TO SET UP LOOKUP FILTER FOR LIST^DIC CALL
AUTHCHK(IBBILLER,IBIFN) ;EP - AUTHORIZED BILLER SCREEN
+1 NEW AUTHORIZER
+2 if '$DATA(IBBILLER)!($GET(IBIFN)="")
QUIT 0
+3 SET AUTHORIZER=$PIECE($GET(^DGCR(399,IBIFN,"S")),U,11)
+4 if AUTHORIZER=""
QUIT 0
+5 QUIT $DATA(IBBILLER(AUTHORIZER))
+6 ;
+7 ;CALLED BY SETARRAY^IBACCWL1
SORTLINE(VALMDDFF,LINENUM,LINE) ;EP - CREATE A LINE TO SEPARATE THE K# SORT FORM NON K# SORT
+1 NEW FIELD,TODATA,X
+2 SET LINE=""
+3 SET FIELD=""
+4 FOR
SET FIELD=$ORDER(VALMDDFF(FIELD))
if FIELD=""
QUIT
Begin DoDot:1
+5 SET TODATA=""
+6 SET FROMWIDTH=$PIECE(VALMDDFF(FIELD),U,3)+1
+7 ;
+8 IF FIELD="LINENUM"
SET TODATA=LINENUM
+9 IF '$TEST
SET $PIECE(TODATA,"-",FROMWIDTH)=""
+10 ;
+11 SET LINE=$$SETFLD^VALM1(TODATA,LINE,FIELD)
End DoDot:1
+12 ;
+13 QUIT
+14 ;
+15 ;ADD PREVIOUS ACTIVITY AND PREVIOUS ACTIVITY COMMENTS - NO USER INTERACTION
+16 ;CALLED FROM RTN IBCE837ACC
ADDPREVACT(RETURN,IBENCIFN,DUZ,ACTCODE,ASSIGNGRP,ASSIGNTOGRP,COMMENT) ;EP - ADD PREVIOUS ACTIVITY - NO USER PROMPT
+1 ;
+2 ;RETURN
+3 NEW ADDIENS,ADDFDA,ADDERR,WPIENS,WPERR
+4 ;
+5 SET ADDIENS="+1,"_IBENCIFN_","
+6 SET ADDFDA(364.94,ADDIENS,.01)="NOW"
+7 SET ADDFDA(364.94,ADDIENS,.02)="`"_$GET(DUZ)
+8 SET ADDFDA(364.94,ADDIENS,.03)=$GET(ACTCODE)
+9 SET ADDFDA(364.94,ADDIENS,.04)=$GET(ASSIGNGRP)
+10 SET ADDFDA(364.94,ADDIENS,.05)=$GET(ASSIGNTOGRP)
+11 ;
+12 DO UPDATE^DIE("ES","ADDFDA","ADDIENS","ADDERR")
+13 ;
+14 IF $DATA(ADDERR)
SET RETURN="0"_U_$GET(ADDERR("DIERR",1,"TEXT",1))
QUIT
+15 ;
+16 SET WPIENS=ADDIENS(1)_","_IBENCIFN_","
+17 ;EDIT PREVIOUS ACTIVITY
DO EDITPREVACT(WPIENS,.COMMENT,.WPERR)
+18 ;
+19 IF $DATA(WPERR)
SET RETURN=WPERR
QUIT
+20 ;
+21 SET RETURN="1^Update Successful"
+22 ;
+23 QUIT
+24 ;
+25 ;CALLED FROM EDITPREVACT^IBACCWLAINONBIL,IBACCWLAINOTLEG,IBACCWLAIREAS,IBACCWLAISERVCON ;REVSTATUSLOOP^IBACCWLAIVIEW ?
+26 ;K WPERR S WPIENS="6,1,",COMMENT(1)="TEST1",COMMENT(2)="TEST2" D EDITPREVACT^IBACCWLUTIL(WPIENS,.COMMENT,.WPERR)
EDITPREVACT(WPIENS,COMMENT,WPERR) ;EP- EDIT PREVIOUS ACTIVITY
+1 ;
+2 DO WP^DIE(364.94,WPIENS,10,"","COMMENT","WPERR")
+3 ;
+4 IF $DATA(WPERR)
Begin DoDot:1
+5 SET RETURN="0"_U_$GET(WPERR("DIERR",1,"TEXT",1))
+6 KILL WPERR
+7 SET WPERR=RETURN
End DoDot:1
+8 ;
+9 QUIT
+10 ;
+11 ;CALLED BY PULLLIST^IBACCWL1,EN^IBACCWLSEC,
+12 ;W $$ISTESTER^IBACCWLUTIL(DUZ)
ISTESTER(DUZ) ;EP - RETURN 1 IF USER IS A PART OF THE ACC CENCOUNTER TEST USER GROUP
+1 ;
+2 NEW XMDUZ
+3 ;
+4 if '$GET(DUZ)
QUIT 0
+5 if $$PROD^XUPROD(1)
QUIT 0
+6 ;
+7 ;ICR #3359 (Private) Pending
SET Y=$$FIND1^DIC(3.8,"","X","IB EBILL TESTERS","B")
+8 IF 'Y
Begin DoDot:1
+9 WRITE !!,"THERE IS NO 'IB EBILL TESTERS' MAIL GROUP!!"
End DoDot:1
QUIT 0
+10 ;
+11 ;ICR #10067 (Supported)
SET XMDUZ=DUZ
DO CHK^XMA21
+12 QUIT $TEST
+13 ;
+14 ;W $$ISITME^IBACCWLUTIL(DUZ)
ISITME(DUZ) ;EP - IS IT TIM? USE ONLY IN BREAKS SO BREAKS OCCUR ONLY FOR TIM F.
+1 if '$GET(DUZ)
QUIT
+2 NEW USERNAME
+3 SET USERNAME=$PIECE($GET(^VA(200,DUZ,0)),U)
+4 if USERNAME=("FRAZIER,TIM")
QUIT 1
+5 QUIT 0
+6 ;
+7 ;W $$MG^IBACCWLUTIL($S)
MG(BYTES) ;EP -CONVERT BYTES TOI MEGABYTES
+1 QUIT BYTES/1000000
+2 ;
+3 ;W $$GG^IBACCWLUTIL($S)
GG(BYTES) ;
+1 QUIT BYTES/1000000000
+2 ;
+3 ;W MG2BYTES^IBACCWLUTIL($S)
MG2BYTES(MG) ;EP -
+1 QUIT MG*1000000
+2 ;
+3 ;K IBAUTH S USERGROUP="BILL" D AUTHORIZER^IBACCWLUTIL(USERGROUP,.IBAUTH)
AUTHORIZER(USERGROUP,IBAUTH) ;EP - FIND ALL AUTHORIZERS GIVEN A GROUP NAME
+1 ;
+2 NEW AUTHORIZER,ENCIFN,GRP,IBIFN
+3 KILL IBAUTH
+4 SET ENCIFN=0
+5 FOR
SET ENCIFN=$ORDER(^IBA(364.9,"AC",USERGROUP,ENCIFN))
if 'ENCIFN
QUIT
Begin DoDot:1
+6 SET IBIFN=$PIECE($GET(^IBA(364.9,ENCIFN,2)),U,2)
+7 if 'IBIFN
QUIT
+8 SET AUTHORIZER=$PIECE($GET(^DGCR(399,IBIFN,"S")),U,11)
+9 if 'AUTHORIZER
QUIT
+10 SET IBAUTH(AUTHORIZER)=$GET(IBAUTH(AUTHORIZER))+1
End DoDot:1
+11 QUIT
+12 ;
GETFLD(FIELD,LINE) ;EP - RETURN CURRENT VALUE OF A DISPLAY FIELD FROM LINE
+1 ;
+2 if '$DATA(FIELD)!('$DATA(LINE))
QUIT 0
+3 NEW IBDA,COLUMN,WIDTH,CURVALUE
+4 SET IBDA=$GET(LINE)
+5 SET COLUMN=$PIECE(FIELD,U,2)
+6 SET WIDTH=$PIECE(FIELD,U,3)
+7 SET CURVALUE=$EXTRACT(LINE(IBDA),COLUMN,COLUMN+(WIDTH-1))
+8 QUIT CURVALUE
