IBACCWLSEC ;EDE/TPF - ACC (Automated Community Care) Encounters - User Group Security ; 12-SEP-2023 ; 12-SEP-2023
;;2.0;INTEGRATED BILLING;**770**;21-MAR-2024;Build 119
;;Per VA Directive 6402, this routine should not be modified.
Q
;This routine is called by option [IBACC WL ACC CLAIMS WORKLIST ACC Claims Worklist
;and acts as a gatekeeper to direct the user to the appropriate work list, displays and action item menu
;given their assigned security key.
;
;IA #6286 (API IA #3277)
;
;D EN^IBACCWLSEC
EN ;EP - ENTRY POINT FOR USER GROUP SECURITY
;CALLED BY OPTION: IBACC WL ACC CLAIMS WORKLIST
N ACCTSTENV,IBSORT,IBDAYSMAX,IBBILLER,IBDIV,IBQUIT,IBUSERKEYSTR,MAXNUMBER,MAXGRRPNUM,NODATA,PIECE,PUBLISHINGON,PUBLISHUPDATE,REP,ROLE,SESSIONKEY,SESSMEMORY,USERGROUP ;GLOBAL SESSION VARS
N IBICAMEFROMEE ;IF TRUE SIGNIFIES A RELOAD CAME FROM ACTION ITEM 'EE ACC Expand Encounter'
N TSTIBINTEGSITE ;TESTING FOR INTEGRATED SITES ONLY ;TPF;IB*2*770v9
N IBPARENT,IBACCWLEELEV,IBACCWLRURREVLEV,IBACCWLVELEV ;TPF;IB*2*770v38;EBILL-5485 PARENT OR CHILD WL? AND LEVEL OF CHILD INSTANTIATION
;
I '$D(^IBA(364.9,0))!'($P($G(^IBA(364.9,0)),U,4)) D Q
.W !!,"FILE #364.9 ACC X12 ENCOUNTERS HAS NOT BEEN FOUND ON YOUR SYSTEM!!"
.W !,"CONTACT YOUR SITE MANAGER."
.S DIR(0)="E"
.D ^DIR
;
S PUBLISHINGON=1 ;DETERMINES WHETHER AN ACTION TAKEN UPDATES OTHER WL DATA ARRAYS (I.E. UPDATES OTHER USER'S DIPLAY SCREENS) IN REAL TIME
S MAXNUMBER=$P($G(^IBA(364.9,0)),U,4)
I MAXNUMBER>999 S MAXNUMBER=1000 ;THROTTLE NO MATTER HOW MANY ENTRIES
;
;MOVED TO HERE FROM SECKEYS API TO USE GLOBALLY
S REP("IBACCBILL")="Billing"
S REP("IBACCFRT")="Facility Revenue"
;S REP("IBACCPTF")="Facility Revenue PTF" ;TPF;IB*2*770v13;EBILL-????
S REP("IBACCPTF")="PTF" ;MJL;IB*2*770v51;EBILL-5978
S REP("IBACCRUR")="Revenue Utilization Review"
S REP("IBACCIV")="Insurance Verification"
S REP("IBACCSUP")="Supervisor"
;
Q:'$$SECKEYS(.IBUSERKEYSTR,.SESSIONKEY)
;
I ($L(IBUSERKEYSTR,U)>1!(IBUSERKEYSTR="None")) D Q:'$D(SESSIONKEY)!$G(NODATA) ;,((DUZ(0)="@")!($$ISTESTER^IBACCWLUTIL(DUZ))) ;TPF;IB*2*770v9
.;
.W !!,"Choose your role." ;TPF;IB*2*770v9
.N DIR,DIRUT,DIROUT,DUOUT,DTOUT,PROMPT,ROLE,SETOFCODES,X,Y
.S PROMPT=""
.F PIECE=1:1 S ROLE=$P(SESSIONKEY,U,PIECE) Q:ROLE="" D
..I ROLE="None" S ROLE="SUP"
..Q:ROLE=""
..I ROLE[("SUP"),'$$ISITME^IBACCWLUTIL(DUZ) Q
..S PROMPT=PROMPT_$E(ROLE,6,$L(ROLE))_":"_ROLE_";"
.;
.S DIR(0)="SO"_U_PROMPT
.I PROMPT[("IBACCFRT") S DIR("B")="FRT" ;TPF;IB*2*770v47;EBILL-6033
.E S DIR("B")=$P(PROMPT,":")
.D ^DIR
.I $D(DUOUT)!$D(DTOUT)!$D(DIROUT)!$D(DIRUT) K SESSIONKEY W !!,"NO ROLE CHOSEN. EXITING WORKLIST!!" Q
.S SESSIONKEY=$G(Y(0))
.;
.N Y D GETENV^%ZOSV ;S ACCTSTENV=Y[("vaausapptas801.aac.domain.ext") ;TPF;IB*2*770v9
.I Y[("vaausapptas801.aac.domain.ext") D Q:'$D(SESSIONKEY) ;TPF;IB*2*770v7 ;TPF;IB*2*770v9
..N DIR,DIRUT,DIROUT,DUOUT,DTOUT,X,Y
..W !!,"CHOOSE INTEGRATED SITES" ;TPF;IB*2*770v18;EBILL-4623
..S DIR("?",1)="As a tester you can test the Special Lookup restrictions for Integrated Sites"
..S DIR("?",2)="which limit how you can enter Station/Division/Integrated Site numbers at the"
..S DIR("?",3)="DIVISION/STATION/FACILITY GROUP: prompt."
..S DIR("?",4)="If you enter an integrated Site number here you will be restricted to entering"
..S DIR("?",5)="Integrated Site numbers belonging to the integrated site you chose."
..S DIR("?",6)="Otherwise there will be no restriction and you can enter any site numbers you"
..S DIR("?",7)="wish and thus mimicking a 'normal' site"
..S DIR("?")="Press Return"
..S DIR(0)="SO^528:NORTHEAST;636:CENTRAL PLAINS I;589:CENTRAL PLAINS II;657:CENTRAL PLAINS III"
..S DIR("A")="Enter the Integrated Site"
..S DIR("B")=""
..D ^DIR
..I $D(DUOUT)!$D(DTOUT)!$D(DIROUT) K SESSIONKEY Q
..S TSTIBINTEGSITE=+Y ;TPF;IB*2*770v9
..S:TSTIBINTEGSITE=0 TSTIBINTEGSITE="NA"
.;
;BEGIN TPF;IB*2*770v45;EBILL-6028 REMOVE DOT SECTION SO EVERYINE GETS THIS PROMPT
S MAXGRRPNUM=$$GRPTOTAL($P(SESSIONKEY,"IBACC",2))
;TPF;IB*2*770v5
I MAXGRRPNUM=0 D Q
.W !!,"NO DATA FOUND FOR WORK GROUP "_$P(SESSIONKEY,"IBACC",2) S NODATA=1
.W !
.N DIR
.S DIR(0)="E"
.D ^DIR
;
I MAXGRRPNUM<MAXNUMBER S MAXNUMBER=MAXGRRPNUM
N DIR
;BEGIN TPF;IB*2*770v46;EBILL-6028
W !!
S DIR(0)="NO^1:"_MAXGRRPNUM
;S DIR("A")="Enter Max Number of records to pull"
S DIR("A")="Limit Number of records to pull" ;TPF;IB*2*770v58;EBILL-6389
;S DIR("?",1)="Enter the maximum number of records you wish to display in your worklist."
;S DIR("?",2)="The number displayed will depend on your filter criteria and the"
;S DIR("?",3)="number of encounters assigned to your work group."
;S DIR("?",4)=" "
;S DIR("?",5)="You cannot enter more than the total assigned to your workgroup which is "_$G(MAXGRRPNUM)_"."
;S DIR("?",6)=" "
;BEGIN TPF;IB*2*770v58;EBILL-6389
S DIR("?",1)="The number of encounters returned to worklist does not exceed the limit"
S DIR("?",2)="entered at prompt; processing starts with oldest encounters and returns"
S DIR("?",3)="results based on filter criteria until limit is met."
S DIR("?",4)=" "
S DIR("?",5)="Cannot enter more than the total available to the worklist which is "_$G(MAXGRRPNUM)_"."
S DIR("?",6)=" "
;END TPF;IB*2*770v58;EBILL-6389
S DIR("?")="Press Return to Continue"
;END TPF;IB*2*770v36;EBILL-5774,5775
S DIR("B")=$G(MAXNUMBER)
D ^DIR
I $D(DUOUT)!$D(DTOUT)!$D(DIROUT) K SESSIONKEY Q
S MAXNUMBER=Y
;END TPF;IB*2*770v46;EBILL-6028
;
W !!
;
S USERGROUP=$P(SESSIONKEY,"IBACC",2)
S IBPARENT=1 ;TPF;IB*2*770vPURPLE;EBILL-5385 ALL STANDARD WORKGROUP WLs ARE PARENTS - DISPLAY MUTLIPLE RECORDS
D EN^VALM("IBACC WL "_SESSIONKEY)
;
Q
;
;S IBUSERKEYSTR=$$GETKEYS^IBACCWL()
SECKEYS(IBUSERKEYSTR,SESSIONKEY,REP) ;EP - GET ACC KEYS ASSIGNED TO USER
;
N IBACCKEYS,NEWLMTEMP,KEYIEN,KEYS,RET
S IBACCKEYS(1)="IBACCBILL" ;RBT - REIMBURSABLE BILLING TECHNICISN
S IBACCKEYS(2)="IBACCFRT" ;FRT - FACILITY REVENUE TECHNICIAN
S IBACCKEYS(3)="IBACCPTF" ;PTF - FACILITY REVENUE TECHNICIAN PTF TPF;;IB*2*770v12;EBILL-4550
S IBACCKEYS(4)="IBACCRUR" ;RUR - RUR NURSE
S IBACCKEYS(5)="IBACCSUP" ;SUP - SUPERVISOR - ASSIGNED IF DEVELOPER OR OWNER IF IBACCSUP SECURITY KEY
S IBACCKEYS(6)="IBACCIV" ;IV - INSURANCE VERIFICATION
;
D OWNSKEY^XUSRB(.RET,.IBACCKEYS) ;IA #3277 (Supported)
;
S IBUSERKEYSTR=""
S KEYIEN=0
F S KEYIEN=$O(RET(KEYIEN)) Q:'KEYIEN D
.Q:'RET(KEYIEN)
.S KEYS=IBACCKEYS(KEYIEN)
.S IBUSERKEYSTR=IBUSERKEYSTR_U_$P(IBACCKEYS(KEYIEN),U)
S IBUSERKEYSTR=$E(IBUSERKEYSTR,2,9999)
S:IBUSERKEYSTR=U!(IBUSERKEYSTR="") IBUSERKEYSTR="None"
;
S SESSIONKEY=IBUSERKEYSTR
;
S NEWLMTEMP=$$REPLACE^XLFSTR(IBUSERKEYSTR,.REP)
S IBUSERKEYSTR=NEWLMTEMP
;
Q 1
;
;TPF;IB*2*770v16;EBILL-EBILL
GRPTOTAL(GROUP) ;EP - CALC NUMBER OF ENTRIES PER WORK GROUP "AC" X-REF
N CNT,IBIFN,IEN
S IEN=0
S CNT=0
;
F S IEN=$O(^IBA(364.9,"AC",GROUP,IEN)) Q:IEN="" D
.Q:$P($G(^IBA(364.9,IEN,0)),U,16)>1 ;SKIP STATUS = CLOSED OR PURGED
.S IBIFN=$P($G(^IBA(364.9,IEN,2)),U,2)
.I $$TRANSMITTED^IBACCWLUTIL1(IBIFN) Q
.S CNT=CNT+1
Q CNT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBACCWLSEC 7343 printed May 25, 2026@12:10:09 Page 2
IBACCWLSEC ;EDE/TPF - ACC (Automated Community Care) Encounters - User Group Security ; 12-SEP-2023 ; 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 ;This routine is called by option [IBACC WL ACC CLAIMS WORKLIST ACC Claims Worklist
+5 ;and acts as a gatekeeper to direct the user to the appropriate work list, displays and action item menu
+6 ;given their assigned security key.
+7 ;
+8 ;IA #6286 (API IA #3277)
+9 ;
+10 ;D EN^IBACCWLSEC
EN ;EP - ENTRY POINT FOR USER GROUP SECURITY
+1 ;CALLED BY OPTION: IBACC WL ACC CLAIMS WORKLIST
+2 ;GLOBAL SESSION VARS
NEW ACCTSTENV,IBSORT,IBDAYSMAX,IBBILLER,IBDIV,IBQUIT,IBUSERKEYSTR,MAXNUMBER,MAXGRRPNUM,NODATA,PIECE,PUBLISHINGON,PUBLISHUPDATE,REP,ROLE,SESSIONKEY,SESSMEMORY,USERGROUP
+3 ;IF TRUE SIGNIFIES A RELOAD CAME FROM ACTION ITEM 'EE ACC Expand Encounter'
NEW IBICAMEFROMEE
+4 ;TESTING FOR INTEGRATED SITES ONLY ;TPF;IB*2*770v9
NEW TSTIBINTEGSITE
+5 ;TPF;IB*2*770v38;EBILL-5485 PARENT OR CHILD WL? AND LEVEL OF CHILD INSTANTIATION
NEW IBPARENT,IBACCWLEELEV,IBACCWLRURREVLEV,IBACCWLVELEV
+6 ;
+7 IF '$DATA(^IBA(364.9,0))!'($PIECE($GET(^IBA(364.9,0)),U,4))
Begin DoDot:1
+8 WRITE !!,"FILE #364.9 ACC X12 ENCOUNTERS HAS NOT BEEN FOUND ON YOUR SYSTEM!!"
+9 WRITE !,"CONTACT YOUR SITE MANAGER."
+10 SET DIR(0)="E"
+11 DO ^DIR
End DoDot:1
QUIT
+12 ;
+13 ;DETERMINES WHETHER AN ACTION TAKEN UPDATES OTHER WL DATA ARRAYS (I.E. UPDATES OTHER USER'S DIPLAY SCREENS) IN REAL TIME
SET PUBLISHINGON=1
+14 SET MAXNUMBER=$PIECE($GET(^IBA(364.9,0)),U,4)
+15 ;THROTTLE NO MATTER HOW MANY ENTRIES
IF MAXNUMBER>999
SET MAXNUMBER=1000
+16 ;
+17 ;MOVED TO HERE FROM SECKEYS API TO USE GLOBALLY
+18 SET REP("IBACCBILL")="Billing"
+19 SET REP("IBACCFRT")="Facility Revenue"
+20 ;S REP("IBACCPTF")="Facility Revenue PTF" ;TPF;IB*2*770v13;EBILL-????
+21 ;MJL;IB*2*770v51;EBILL-5978
SET REP("IBACCPTF")="PTF"
+22 SET REP("IBACCRUR")="Revenue Utilization Review"
+23 SET REP("IBACCIV")="Insurance Verification"
+24 SET REP("IBACCSUP")="Supervisor"
+25 ;
+26 if '$$SECKEYS(.IBUSERKEYSTR,.SESSIONKEY)
QUIT
+27 ;
+28 ;,((DUZ(0)="@")!($$ISTESTER^IBACCWLUTIL(DUZ))) ;TPF;IB*2*770v9
IF ($LENGTH(IBUSERKEYSTR,U)>1!(IBUSERKEYSTR="None"))
Begin DoDot:1
+29 ;
+30 ;TPF;IB*2*770v9
WRITE !!,"Choose your role."
+31 NEW DIR,DIRUT,DIROUT,DUOUT,DTOUT,PROMPT,ROLE,SETOFCODES,X,Y
+32 SET PROMPT=""
+33 FOR PIECE=1:1
SET ROLE=$PIECE(SESSIONKEY,U,PIECE)
if ROLE=""
QUIT
Begin DoDot:2
+34 IF ROLE="None"
SET ROLE="SUP"
+35 if ROLE=""
QUIT
+36 IF ROLE[("SUP")
IF '$$ISITME^IBACCWLUTIL(DUZ)
QUIT
+37 SET PROMPT=PROMPT_$EXTRACT(ROLE,6,$LENGTH(ROLE))_":"_ROLE_";"
End DoDot:2
+38 ;
+39 SET DIR(0)="SO"_U_PROMPT
+40 ;TPF;IB*2*770v47;EBILL-6033
IF PROMPT[("IBACCFRT")
SET DIR("B")="FRT"
+41 IF '$TEST
SET DIR("B")=$PIECE(PROMPT,":")
+42 DO ^DIR
+43 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)!$DATA(DIRUT)
KILL SESSIONKEY
WRITE !!,"NO ROLE CHOSEN. EXITING WORKLIST!!"
QUIT
+44 SET SESSIONKEY=$GET(Y(0))
+45 ;
+46 ;S ACCTSTENV=Y[("vaausapptas801.aac.domain.ext") ;TPF;IB*2*770v9
NEW Y
DO GETENV^%ZOSV
+47 ;TPF;IB*2*770v7 ;TPF;IB*2*770v9
IF Y[("vaausapptas801.aac.domain.ext")
Begin DoDot:2
+48 NEW DIR,DIRUT,DIROUT,DUOUT,DTOUT,X,Y
+49 ;TPF;IB*2*770v18;EBILL-4623
WRITE !!,"CHOOSE INTEGRATED SITES"
+50 SET DIR("?",1)="As a tester you can test the Special Lookup restrictions for Integrated Sites"
+51 SET DIR("?",2)="which limit how you can enter Station/Division/Integrated Site numbers at the"
+52 SET DIR("?",3)="DIVISION/STATION/FACILITY GROUP: prompt."
+53 SET DIR("?",4)="If you enter an integrated Site number here you will be restricted to entering"
+54 SET DIR("?",5)="Integrated Site numbers belonging to the integrated site you chose."
+55 SET DIR("?",6)="Otherwise there will be no restriction and you can enter any site numbers you"
+56 SET DIR("?",7)="wish and thus mimicking a 'normal' site"
+57 SET DIR("?")="Press Return"
+58 SET DIR(0)="SO^528:NORTHEAST;636:CENTRAL PLAINS I;589:CENTRAL PLAINS II;657:CENTRAL PLAINS III"
+59 SET DIR("A")="Enter the Integrated Site"
+60 SET DIR("B")=""
+61 DO ^DIR
+62 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
KILL SESSIONKEY
QUIT
+63 ;TPF;IB*2*770v9
SET TSTIBINTEGSITE=+Y
+64 if TSTIBINTEGSITE=0
SET TSTIBINTEGSITE="NA"
End DoDot:2
if '$DATA(SESSIONKEY)
QUIT
+65 ;
End DoDot:1
if '$DATA(SESSIONKEY)!$GET(NODATA)
QUIT
+66 ;BEGIN TPF;IB*2*770v45;EBILL-6028 REMOVE DOT SECTION SO EVERYINE GETS THIS PROMPT
+67 SET MAXGRRPNUM=$$GRPTOTAL($PIECE(SESSIONKEY,"IBACC",2))
+68 ;TPF;IB*2*770v5
+69 IF MAXGRRPNUM=0
Begin DoDot:1
+70 WRITE !!,"NO DATA FOUND FOR WORK GROUP "_$PIECE(SESSIONKEY,"IBACC",2)
SET NODATA=1
+71 WRITE !
+72 NEW DIR
+73 SET DIR(0)="E"
+74 DO ^DIR
End DoDot:1
QUIT
+75 ;
+76 IF MAXGRRPNUM<MAXNUMBER
SET MAXNUMBER=MAXGRRPNUM
+77 NEW DIR
+78 ;BEGIN TPF;IB*2*770v46;EBILL-6028
+79 WRITE !!
+80 SET DIR(0)="NO^1:"_MAXGRRPNUM
+81 ;S DIR("A")="Enter Max Number of records to pull"
+82 ;TPF;IB*2*770v58;EBILL-6389
SET DIR("A")="Limit Number of records to pull"
+83 ;S DIR("?",1)="Enter the maximum number of records you wish to display in your worklist."
+84 ;S DIR("?",2)="The number displayed will depend on your filter criteria and the"
+85 ;S DIR("?",3)="number of encounters assigned to your work group."
+86 ;S DIR("?",4)=" "
+87 ;S DIR("?",5)="You cannot enter more than the total assigned to your workgroup which is "_$G(MAXGRRPNUM)_"."
+88 ;S DIR("?",6)=" "
+89 ;BEGIN TPF;IB*2*770v58;EBILL-6389
+90 SET DIR("?",1)="The number of encounters returned to worklist does not exceed the limit"
+91 SET DIR("?",2)="entered at prompt; processing starts with oldest encounters and returns"
+92 SET DIR("?",3)="results based on filter criteria until limit is met."
+93 SET DIR("?",4)=" "
+94 SET DIR("?",5)="Cannot enter more than the total available to the worklist which is "_$GET(MAXGRRPNUM)_"."
+95 SET DIR("?",6)=" "
+96 ;END TPF;IB*2*770v58;EBILL-6389
+97 SET DIR("?")="Press Return to Continue"
+98 ;END TPF;IB*2*770v36;EBILL-5774,5775
+99 SET DIR("B")=$GET(MAXNUMBER)
+100 DO ^DIR
+101 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
KILL SESSIONKEY
QUIT
+102 SET MAXNUMBER=Y
+103 ;END TPF;IB*2*770v46;EBILL-6028
+104 ;
+105 WRITE !!
+106 ;
+107 SET USERGROUP=$PIECE(SESSIONKEY,"IBACC",2)
+108 ;TPF;IB*2*770vPURPLE;EBILL-5385 ALL STANDARD WORKGROUP WLs ARE PARENTS - DISPLAY MUTLIPLE RECORDS
SET IBPARENT=1
+109 DO EN^VALM("IBACC WL "_SESSIONKEY)
+110 ;
+111 QUIT
+112 ;
+113 ;S IBUSERKEYSTR=$$GETKEYS^IBACCWL()
SECKEYS(IBUSERKEYSTR,SESSIONKEY,REP) ;EP - GET ACC KEYS ASSIGNED TO USER
+1 ;
+2 NEW IBACCKEYS,NEWLMTEMP,KEYIEN,KEYS,RET
+3 ;RBT - REIMBURSABLE BILLING TECHNICISN
SET IBACCKEYS(1)="IBACCBILL"
+4 ;FRT - FACILITY REVENUE TECHNICIAN
SET IBACCKEYS(2)="IBACCFRT"
+5 ;PTF - FACILITY REVENUE TECHNICIAN PTF TPF;;IB*2*770v12;EBILL-4550
SET IBACCKEYS(3)="IBACCPTF"
+6 ;RUR - RUR NURSE
SET IBACCKEYS(4)="IBACCRUR"
+7 ;SUP - SUPERVISOR - ASSIGNED IF DEVELOPER OR OWNER IF IBACCSUP SECURITY KEY
SET IBACCKEYS(5)="IBACCSUP"
+8 ;IV - INSURANCE VERIFICATION
SET IBACCKEYS(6)="IBACCIV"
+9 ;
+10 ;IA #3277 (Supported)
DO OWNSKEY^XUSRB(.RET,.IBACCKEYS)
+11 ;
+12 SET IBUSERKEYSTR=""
+13 SET KEYIEN=0
+14 FOR
SET KEYIEN=$ORDER(RET(KEYIEN))
if 'KEYIEN
QUIT
Begin DoDot:1
+15 if 'RET(KEYIEN)
QUIT
+16 SET KEYS=IBACCKEYS(KEYIEN)
+17 SET IBUSERKEYSTR=IBUSERKEYSTR_U_$PIECE(IBACCKEYS(KEYIEN),U)
End DoDot:1
+18 SET IBUSERKEYSTR=$EXTRACT(IBUSERKEYSTR,2,9999)
+19 if IBUSERKEYSTR=U!(IBUSERKEYSTR="")
SET IBUSERKEYSTR="None"
+20 ;
+21 SET SESSIONKEY=IBUSERKEYSTR
+22 ;
+23 SET NEWLMTEMP=$$REPLACE^XLFSTR(IBUSERKEYSTR,.REP)
+24 SET IBUSERKEYSTR=NEWLMTEMP
+25 ;
+26 QUIT 1
+27 ;
+28 ;TPF;IB*2*770v16;EBILL-EBILL
GRPTOTAL(GROUP) ;EP - CALC NUMBER OF ENTRIES PER WORK GROUP "AC" X-REF
+1 NEW CNT,IBIFN,IEN
+2 SET IEN=0
+3 SET CNT=0
+4 ;
+5 FOR
SET IEN=$ORDER(^IBA(364.9,"AC",GROUP,IEN))
if IEN=""
QUIT
Begin DoDot:1
+6 ;SKIP STATUS = CLOSED OR PURGED
if $PIECE($GET(^IBA(364.9,IEN,0)),U,16)>1
QUIT
+7 SET IBIFN=$PIECE($GET(^IBA(364.9,IEN,2)),U,2)
+8 IF $$TRANSMITTED^IBACCWLUTIL1(IBIFN)
QUIT
+9 SET CNT=CNT+1
End DoDot:1
+10 QUIT CNT
