IBACCWLSPKUP ;EDE/TPF - ACC (Automated Community Care) Encounters - Special Lookup Prompt for ACC DIVISION ROLLUP ; 12-SEP-2023
;;2.0;INTEGRATED BILLING;**770**;21-MAR-2024;Build 119
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
;CALLED FROM IBACCWLSORT
;EP - SPECIAL LOOKUP FOR #364.99 ACC DIVISION ... FILE
SPECLKUP(RETURN) ;EP - SPECIAL LOOKUP RTN FOR ACC DIVISION ROLLUP
N ALL,DIR,DIV,DUOUT,DIROUT,DTOUT,ERROR,FIELDS,FLAGS,IBTARGET,IDENTIFIER,IENS,LISTRETURN,SPMAXNUMBER,PART,PREVX,RETURNIEN,SCREEN,SETOFCODES,SPECINT,X
N HELP ;TPF XINDEX
;
S DIR(0)="FO^3:7^K:X'?1(3N,3N2A,4N2A,3A,1""-"".E) X" ;3N OR 3N2A OR 3A ;,1.3AN ,1"-".E
I ("^528^636^589^657^"[(U_$P($$SITE^VASITE,U,3)_U)) D SETDIRUP($P($$SITE^VASITE,U,3),.SETOFCODES) S DIR("PRE")="D SPEC^IBACCWLSPKUP(.SPECINT)" S DIR(0)="SO^"_SETOFCODES ;FOR ALL INTEGRATED SITES ;TPF;IB*2*770v11
;
S DIR("A")="DIVISION/STATION/FACILITY GROUP"
I '$D(IBDIV) S DIR("B")="ALL"
E S DIR("A")="Another DIVISION/STATION/FACILITY GROUP" K DIR("B")
S DIR("?",1)="Enter the Station Number, Division number or a Facility Group number which you"
S DIR("?",2)="wish to appear in your worklist."
S DIR("?",3)=""
S DIR("?",4)="A Station or Division Number can be three to seven alphanumeric characters"
S DIR("?",5)="e.g. 333, 333AB, 333ABC, 6369AA."
S DIR("?",6)=" "
S DIR("?",7)="A Facility Group number is three Alpha characters that represents a billing"
S DIR("?",8)="bucket where the bills from several stations and/or divisions are billed."
S DIR("?",9)="If you wish to list the ACC Encounters for a specific Facility Group, just enter"
S DIR("?",10)="the Facility Group e.g. CIA, CHE or NMX and all the Station Numbers"
S DIR("?",11)="within that Facility Group will be included in your worklist."
S DIR("?",12)=""
S DIR("?",13)="If you enter ALL, all Stations and Divisions will be included in your worklist."
S DIR("?",14)=" "
S DIR("?",15)="If you enter 333 the station 333 will be included in your worklist." ;TPF;IB*2*770v9
S DIR("?",16)="If you enter -333 the station 333 will not be included in your worklist." ;TPF;IB*2*770v9
S DIR("?",17)=" "
S DIR("?",18)="If you enter -ALL, your worklist filter will be cleared and you will be" ;TPF;IB*2*770v9
S DIR("?",19)="allowed to build a new worklist filter." ;TPF;IB*2*770v9
S DIR("?",20)=" "
S DIR("?",21)="Enter ""^"" to clear your worklist filter and return to the" ;TPF;IB*2*770v9
S DIR("?",22)="MINIMUM # OF DAYS ON THE WORKLIST prompt."
S DIR("?",23)=" "
S DIR("?")="Press <Enter> when you are finished."
;
S HELP=2
;
D ^DIR
;
I $G(SPECINT)'="" S X=SPECINT
I X="",'$D(IBDIV) S RETURN="1^ESCAPE",RETURN(1)=$G(X) Q ;TPF;IB*2*770v9
I X="",$D(IBDIV) S RETURN="1^FINISHED",RETURN(1)=$G(X) Q ;TPF;IB*2*770v9
;
I X="ALL" D Q ;TPF;IB*2*770v9
.W !!,"You have chosen to include all Stations and Divisions in your worklist."
.K IBDIV
.S RETURN="1^FINISHED",RETURN(1)=$G(X)
;
I $D(DUOUT)!$D(DIROUT)!$D(DTOUT)!(X="-ALL")!(X="") D Q:$G(RETURN)
.I '$D(IBDIV) S RETURN="1^ESCAPE",RETURN(1)=$G(X) D Q ;TPF;IB*2*770v9
..W !!,"There were no selections in the worklist inclusion list." ;IB*2*770v9
..W !!,"If you wish to exit enter a ""^"""
.I X'="-ALL",(X'="") W !,"If you exit now you will lose the worklist inclusion list!"
.E I X="-ALL" W !,"Your worklist filter will be cleared and you will need to enter new",!,"filter criteria." ;TPF;IB*2*770v9
.S PREVX=X
.N Y,DIR,DUOUT,DIROUT,DTOUT
.S DIR(0)="YO"
.S DIR("A")="ARE YOU SURE"
.S DIR("B")="N"
.D ^DIR
.;
.I PREVX=U S RETURN="1^ESCAPE" S VALMQUIT=1 Q ;TPF;IB*2*770v29;EBILL-5297
.Q:$D(DUOUT)!$D(DIROUT)!$D(DTOUT)!(X="N")
.K IBDIV
.I PREVX=U S RETURN="1^ESCAPE" S VALMQUIT=1 Q ;TPF;IB*2*770v29;EBILL-5297
.I PREVX="-ALL" S RETURN="0^NOT FINISHED"
.S RETURN="0^ESCAPE"
;
I $G(ALL)[("ALL") S RETURN="0^ALL" Q
I $E(X)="-" D DEL(X,.IBDIV) S RETURN="0^-" Q
S IBTARGET=Y
;
S SCREEN=""
;
S INDEX="M"
I IBTARGET?3N S INDEX="B" ;S SCREEN="I $P(^(0),U)=IBTARGET"
I IBTARGET?3N2A S INDEX="B" ;S SCREEN="I $P(^(0),U)=IBTARGET"
I IBTARGET?3A S INDEX="C",SCREEN="I '$P(^(0),U,5)" ;WCJ;v13;EBILL-3797;screen deactivated stations
;
S IENS=""
S FIELDS="@;.01;.02;.03;.04"
S FLAGS="O" ;ERRORS IN DATA RETURNED AS NULL AND PROCESSING CONTINUES. EXACT MATCH IF POSSIBLE
S SPMAXNUMBER=""
S IDENTIFIER=""
K RETURN,ERROR
;
D FIND^DIC(364.99,IENS,FIELDS,FLAGS,IBTARGET,SPMAXNUMBER,INDEX,SCREEN,IDENTIFIER,"RETURN","ERROR")
;
S RETURNIEN=0
F S RETURNIEN=$O(RETURN("DILIST","ID",RETURNIEN)) Q:'RETURNIEN D
.S DIV=RETURN("DILIST","ID",RETURNIEN,.01)
.I $D(IBDIV(DIV)) W !,"This Division/Station/Facility Group "_DIV_" has already been selected!" Q
.S IBFIRST=0
.S IBDIV(DIV)=""
;
D CURIBDIV(.IBDIV,0)
;
Q
;
CURIBDIV(IBDIV,HELP) ;EP - DISPLAY CURRENT WORKLIST FILTER ARRAY
;HELP = THE LAST # IN THE S DIR("?",16) ARRAY
I '$D(IBDIV) D Q
.W !!,"There are no Stations/Divisions/Facility Groups in your worklist filter!"
;
W !!,"The following Stations/Divisions/Facility Groups will be included"
W !,"in your worklist:"
W !
;I HELP S HELP=HELP+1 S DIR("?",HELP)=" ",HELP=HELP+1,DIR("?",HELP)="The following Stations will be included in your worklist:"
N STAT,STATIEN
S STAT=0
F S STAT=$O(IBDIV(STAT)) Q:'STAT D
.S STATIEN=$O(^DIC(4,"D",STAT,0)) ;ICR #10090 (Supported)
.W !,STAT," "
.I STATIEN W $P($G(^DIC(4,STATIEN,0)),U) ;ICR #10090 (Supported)
.;
W !!
Q
;
DEL(DELSTAT,IBDIV) ;EP - DELETE ITEMS FROM WORKLIST FILTER ARRAY
;
N FACGRP,IEN,NAME
S DELSTAT=$$UP^XLFSTR($E(DELSTAT,2,8))
I DELSTAT'?3A K IBDIV(DELSTAT) W !!,"Station/Division Number "_DELSTAT_" will not appear on your worklist!",! D CURIBDIV(.IBDIV,0) Q
S FACGRP=$E(DELSTAT,1,8)
W !!,"Facility Group "_DELSTAT_" will not appear on your worklist!",!
S IEN=0
F S IEN=$O(^IBA(364.99,"C",FACGRP,IEN)) Q:'IEN D
.S NAME=$P($G(^IBA(364.99,IEN,0)),U)
.K IBDIV(NAME)
;
D CURIBDIV(.IBDIV,0)
;
Q
;
PAUSE ;EP - RETURN TO CONT
N DIR
S DIR(0)="E"
D ^DIR
Q
;
SPECLKPXREF(X,TYPE) ;EP - XREF FOR FACILITY GROUP RESTRICTIONS
;
N SITE
;or help on global specifications DO HELP^%G
;^IBA(364.99,"AC" -- NOTE: translation in effect
;^IBA(364.99,"AC","S X","ALB")=1
; "ALT")=6
;TYPE= KILL OR SET
I TYPE="S" D
.S FACGRP=X
.S SITE=$P(^IBA(364.99,DA,0),U)
.Q:"^528^636^589^657^"'[(U_$E(SITE,1,3)_U)
.;
.S ^IBA(364.99,"E",$E(SITE,1,3),FACGRP,DA)=""
;
I TYPE="K" D
.K ^IBA(364.99,"E",X)
;
Q
;
;D SETXREF^IBACCSPECLKUP
SETXREF ;EP
N DA,DIK
S DIK="^IBA(364.99,"
S DIK(1)=".02^E"
S DA=0
F S DA=$O(^IBA(364.99,DA)) Q:'DA D
.D EN1^DIK
;
Q
;
;#364.99 ACC DIVISION ROLLUP
;D SETDIRUP^IBACCWLSPKUP($P($$SITE^VASITE,U,3),.SETOFCODES) ;TPF;IB*2*770v9
SETDIRUP(VASITE,SETOFCODES) ;EP - SET DIR(0) UP WITH SET OF CODES FOR EACH INTEGRATED SITE USING "E" X-REF ;TPF;IB*2*770v9
;
N FACGRP,INTSITE,INSTSTATNUM,MORE,OFFNAME,STATNAME,STATNUM
K SETOFCODES
;
S FACGRP=""
F S FACGRP=$O(^IBA(364.99,"E",VASITE,FACGRP)) Q:FACGRP="" D ;TPF;IB*2*770v9
.S INTSITE=$O(^IBA(364.99,"C",FACGRP,0))
.S STATNUM=$P($G(^IBA(364.99,INTSITE,0)),U) ;="636^NWI
.S INSTSTATNUM=$$RUST^IBACCROWFT(STATNUM) ;WCJ;v10
.S STATIEN=$O(^DIC(4,"D",INSTSTATNUM,"")) ;WCJ;v10 ;ICR #10090 (Supported)
.Q:'STATIEN
.S OFFNAME=$P($G(^DIC(4,STATIEN,99)),U,3) ;OFFICIAL VA NAME: VA HEALTHCARE NETWORK UPSTATE ;ICR #10090 (Supported)
.S STATNAME=$P($G(^DIC(4,STATIEN,0)),U)_" ("_INSTSTATNUM_")" ;ICR #10090 (Supported)
.S SETOFCODES=$G(SETOFCODES)_FACGRP_":"_STATNAME
.S MORE=$O(^IBA(364.99,"E",VASITE,FACGRP)) I MORE'="" S SETOFCODES=SETOFCODES_";" ;TPF;IB*2*770v9
S SETOFCODES=$G(SETOFCODES)_";ALL:ALL AVAILABLE FACILITY GROUPS" ;TPF;IB*2*770v9
;
Q
;
;VA FILEMAN V22.2 DEVELOPER'S GUIDE SECTION 2.3.47.3
;THIS IS DONE TO HANDLE USER ENTERING A THREE CHAR 'FACILITY GROUP"
SPEC(SPECINT) ;EP - SPECIAL PRE-VALIDATION TRANSFORM FOR INTEGRATED SITES
;
S SPECINT=""
I X?1"-"3A S SPECINT=X S X="" Q
I X?1"-".E I '$D(IBDIV($E(X,2,999))) W !,$E(X,2,999)_" NOT IN CURRENT SELECTION LIST" Q
I X?1"-".E S SPECINT=X S X="" Q
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBACCWLSPKUP 8372 printed May 25, 2026@12:10:12 Page 2
IBACCWLSPKUP ;EDE/TPF - ACC (Automated Community Care) Encounters - Special Lookup Prompt for ACC DIVISION ROLLUP ; 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 QUIT
+5 ;
+6 ;CALLED FROM IBACCWLSORT
+7 ;EP - SPECIAL LOOKUP FOR #364.99 ACC DIVISION ... FILE
SPECLKUP(RETURN) ;EP - SPECIAL LOOKUP RTN FOR ACC DIVISION ROLLUP
+1 NEW ALL,DIR,DIV,DUOUT,DIROUT,DTOUT,ERROR,FIELDS,FLAGS,IBTARGET,IDENTIFIER,IENS,LISTRETURN,SPMAXNUMBER,PART,PREVX,RETURNIEN,SCREEN,SETOFCODES,SPECINT,X
+2 ;TPF XINDEX
NEW HELP
+3 ;
+4 ;3N OR 3N2A OR 3A ;,1.3AN ,1"-".E
SET DIR(0)="FO^3:7^K:X'?1(3N,3N2A,4N2A,3A,1""-"".E) X"
+5 ;FOR ALL INTEGRATED SITES ;TPF;IB*2*770v11
IF ("^528^636^589^657^"[(U_$PIECE($$SITE^VASITE,U,3)_U))
DO SETDIRUP($PIECE($$SITE^VASITE,U,3),.SETOFCODES)
SET DIR("PRE")="D SPEC^IBACCWLSPKUP(.SPECINT)"
SET DIR(0)="SO^"_SETOFCODES
+6 ;
+7 SET DIR("A")="DIVISION/STATION/FACILITY GROUP"
+8 IF '$DATA(IBDIV)
SET DIR("B")="ALL"
+9 IF '$TEST
SET DIR("A")="Another DIVISION/STATION/FACILITY GROUP"
KILL DIR("B")
+10 SET DIR("?",1)="Enter the Station Number, Division number or a Facility Group number which you"
+11 SET DIR("?",2)="wish to appear in your worklist."
+12 SET DIR("?",3)=""
+13 SET DIR("?",4)="A Station or Division Number can be three to seven alphanumeric characters"
+14 SET DIR("?",5)="e.g. 333, 333AB, 333ABC, 6369AA."
+15 SET DIR("?",6)=" "
+16 SET DIR("?",7)="A Facility Group number is three Alpha characters that represents a billing"
+17 SET DIR("?",8)="bucket where the bills from several stations and/or divisions are billed."
+18 SET DIR("?",9)="If you wish to list the ACC Encounters for a specific Facility Group, just enter"
+19 SET DIR("?",10)="the Facility Group e.g. CIA, CHE or NMX and all the Station Numbers"
+20 SET DIR("?",11)="within that Facility Group will be included in your worklist."
+21 SET DIR("?",12)=""
+22 SET DIR("?",13)="If you enter ALL, all Stations and Divisions will be included in your worklist."
+23 SET DIR("?",14)=" "
+24 ;TPF;IB*2*770v9
SET DIR("?",15)="If you enter 333 the station 333 will be included in your worklist."
+25 ;TPF;IB*2*770v9
SET DIR("?",16)="If you enter -333 the station 333 will not be included in your worklist."
+26 SET DIR("?",17)=" "
+27 ;TPF;IB*2*770v9
SET DIR("?",18)="If you enter -ALL, your worklist filter will be cleared and you will be"
+28 ;TPF;IB*2*770v9
SET DIR("?",19)="allowed to build a new worklist filter."
+29 SET DIR("?",20)=" "
+30 ;TPF;IB*2*770v9
SET DIR("?",21)="Enter ""^"" to clear your worklist filter and return to the"
+31 SET DIR("?",22)="MINIMUM # OF DAYS ON THE WORKLIST prompt."
+32 SET DIR("?",23)=" "
+33 SET DIR("?")="Press <Enter> when you are finished."
+34 ;
+35 SET HELP=2
+36 ;
+37 DO ^DIR
+38 ;
+39 IF $GET(SPECINT)'=""
SET X=SPECINT
+40 ;TPF;IB*2*770v9
IF X=""
IF '$DATA(IBDIV)
SET RETURN="1^ESCAPE"
SET RETURN(1)=$GET(X)
QUIT
+41 ;TPF;IB*2*770v9
IF X=""
IF $DATA(IBDIV)
SET RETURN="1^FINISHED"
SET RETURN(1)=$GET(X)
QUIT
+42 ;
+43 ;TPF;IB*2*770v9
IF X="ALL"
Begin DoDot:1
+44 WRITE !!,"You have chosen to include all Stations and Divisions in your worklist."
+45 KILL IBDIV
+46 SET RETURN="1^FINISHED"
SET RETURN(1)=$GET(X)
End DoDot:1
QUIT
+47 ;
+48 IF $DATA(DUOUT)!$DATA(DIROUT)!$DATA(DTOUT)!(X="-ALL")!(X="")
Begin DoDot:1
+49 ;TPF;IB*2*770v9
IF '$DATA(IBDIV)
SET RETURN="1^ESCAPE"
SET RETURN(1)=$GET(X)
Begin DoDot:2
+50 ;IB*2*770v9
WRITE !!,"There were no selections in the worklist inclusion list."
+51 WRITE !!,"If you wish to exit enter a ""^"""
End DoDot:2
QUIT
+52 IF X'="-ALL"
IF (X'="")
WRITE !,"If you exit now you will lose the worklist inclusion list!"
+53 ;TPF;IB*2*770v9
IF '$TEST
IF X="-ALL"
WRITE !,"Your worklist filter will be cleared and you will need to enter new",!,"filter criteria."
+54 SET PREVX=X
+55 NEW Y,DIR,DUOUT,DIROUT,DTOUT
+56 SET DIR(0)="YO"
+57 SET DIR("A")="ARE YOU SURE"
+58 SET DIR("B")="N"
+59 DO ^DIR
+60 ;
+61 ;TPF;IB*2*770v29;EBILL-5297
IF PREVX=U
SET RETURN="1^ESCAPE"
SET VALMQUIT=1
QUIT
+62 if $DATA(DUOUT)!$DATA(DIROUT)!$DATA(DTOUT)!(X="N")
QUIT
+63 KILL IBDIV
+64 ;TPF;IB*2*770v29;EBILL-5297
IF PREVX=U
SET RETURN="1^ESCAPE"
SET VALMQUIT=1
QUIT
+65 IF PREVX="-ALL"
SET RETURN="0^NOT FINISHED"
+66 SET RETURN="0^ESCAPE"
End DoDot:1
if $GET(RETURN)
QUIT
+67 ;
+68 IF $GET(ALL)[("ALL")
SET RETURN="0^ALL"
QUIT
+69 IF $EXTRACT(X)="-"
DO DEL(X,.IBDIV)
SET RETURN="0^-"
QUIT
+70 SET IBTARGET=Y
+71 ;
+72 SET SCREEN=""
+73 ;
+74 SET INDEX="M"
+75 ;S SCREEN="I $P(^(0),U)=IBTARGET"
IF IBTARGET?3N
SET INDEX="B"
+76 ;S SCREEN="I $P(^(0),U)=IBTARGET"
IF IBTARGET?3N2A
SET INDEX="B"
+77 ;WCJ;v13;EBILL-3797;screen deactivated stations
IF IBTARGET?3A
SET INDEX="C"
SET SCREEN="I '$P(^(0),U,5)"
+78 ;
+79 SET IENS=""
+80 SET FIELDS="@;.01;.02;.03;.04"
+81 ;ERRORS IN DATA RETURNED AS NULL AND PROCESSING CONTINUES. EXACT MATCH IF POSSIBLE
SET FLAGS="O"
+82 SET SPMAXNUMBER=""
+83 SET IDENTIFIER=""
+84 KILL RETURN,ERROR
+85 ;
+86 DO FIND^DIC(364.99,IENS,FIELDS,FLAGS,IBTARGET,SPMAXNUMBER,INDEX,SCREEN,IDENTIFIER,"RETURN","ERROR")
+87 ;
+88 SET RETURNIEN=0
+89 FOR
SET RETURNIEN=$ORDER(RETURN("DILIST","ID",RETURNIEN))
if 'RETURNIEN
QUIT
Begin DoDot:1
+90 SET DIV=RETURN("DILIST","ID",RETURNIEN,.01)
+91 IF $DATA(IBDIV(DIV))
WRITE !,"This Division/Station/Facility Group "_DIV_" has already been selected!"
QUIT
+92 SET IBFIRST=0
+93 SET IBDIV(DIV)=""
End DoDot:1
+94 ;
+95 DO CURIBDIV(.IBDIV,0)
+96 ;
+97 QUIT
+98 ;
CURIBDIV(IBDIV,HELP) ;EP - DISPLAY CURRENT WORKLIST FILTER ARRAY
+1 ;HELP = THE LAST # IN THE S DIR("?",16) ARRAY
+2 IF '$DATA(IBDIV)
Begin DoDot:1
+3 WRITE !!,"There are no Stations/Divisions/Facility Groups in your worklist filter!"
End DoDot:1
QUIT
+4 ;
+5 WRITE !!,"The following Stations/Divisions/Facility Groups will be included"
+6 WRITE !,"in your worklist:"
+7 WRITE !
+8 ;I HELP S HELP=HELP+1 S DIR("?",HELP)=" ",HELP=HELP+1,DIR("?",HELP)="The following Stations will be included in your worklist:"
+9 NEW STAT,STATIEN
+10 SET STAT=0
+11 FOR
SET STAT=$ORDER(IBDIV(STAT))
if 'STAT
QUIT
Begin DoDot:1
+12 ;ICR #10090 (Supported)
SET STATIEN=$ORDER(^DIC(4,"D",STAT,0))
+13 WRITE !,STAT," "
+14 ;ICR #10090 (Supported)
IF STATIEN
WRITE $PIECE($GET(^DIC(4,STATIEN,0)),U)
+15 ;
End DoDot:1
+16 WRITE !!
+17 QUIT
+18 ;
DEL(DELSTAT,IBDIV) ;EP - DELETE ITEMS FROM WORKLIST FILTER ARRAY
+1 ;
+2 NEW FACGRP,IEN,NAME
+3 SET DELSTAT=$$UP^XLFSTR($EXTRACT(DELSTAT,2,8))
+4 IF DELSTAT'?3A
KILL IBDIV(DELSTAT)
WRITE !!,"Station/Division Number "_DELSTAT_" will not appear on your worklist!",!
DO CURIBDIV(.IBDIV,0)
QUIT
+5 SET FACGRP=$EXTRACT(DELSTAT,1,8)
+6 WRITE !!,"Facility Group "_DELSTAT_" will not appear on your worklist!",!
+7 SET IEN=0
+8 FOR
SET IEN=$ORDER(^IBA(364.99,"C",FACGRP,IEN))
if 'IEN
QUIT
Begin DoDot:1
+9 SET NAME=$PIECE($GET(^IBA(364.99,IEN,0)),U)
+10 KILL IBDIV(NAME)
End DoDot:1
+11 ;
+12 DO CURIBDIV(.IBDIV,0)
+13 ;
+14 QUIT
+15 ;
PAUSE ;EP - RETURN TO CONT
+1 NEW DIR
+2 SET DIR(0)="E"
+3 DO ^DIR
+4 QUIT
+5 ;
SPECLKPXREF(X,TYPE) ;EP - XREF FOR FACILITY GROUP RESTRICTIONS
+1 ;
+2 NEW SITE
+3 ;or help on global specifications DO HELP^%G
+4 ;^IBA(364.99,"AC" -- NOTE: translation in effect
+5 ;^IBA(364.99,"AC","S X","ALB")=1
+6 ; "ALT")=6
+7 ;TYPE= KILL OR SET
+8 IF TYPE="S"
Begin DoDot:1
+9 SET FACGRP=X
+10 SET SITE=$PIECE(^IBA(364.99,DA,0),U)
+11 if "^528^636^589^657^"'[(U_$EXTRACT(SITE,1,3)_U)
QUIT
+12 ;
+13 SET ^IBA(364.99,"E",$EXTRACT(SITE,1,3),FACGRP,DA)=""
End DoDot:1
+14 ;
+15 IF TYPE="K"
Begin DoDot:1
+16 KILL ^IBA(364.99,"E",X)
End DoDot:1
+17 ;
+18 QUIT
+19 ;
+20 ;D SETXREF^IBACCSPECLKUP
SETXREF ;EP
+1 NEW DA,DIK
+2 SET DIK="^IBA(364.99,"
+3 SET DIK(1)=".02^E"
+4 SET DA=0
+5 FOR
SET DA=$ORDER(^IBA(364.99,DA))
if 'DA
QUIT
Begin DoDot:1
+6 DO EN1^DIK
End DoDot:1
+7 ;
+8 QUIT
+9 ;
+10 ;#364.99 ACC DIVISION ROLLUP
+11 ;D SETDIRUP^IBACCWLSPKUP($P($$SITE^VASITE,U,3),.SETOFCODES) ;TPF;IB*2*770v9
SETDIRUP(VASITE,SETOFCODES) ;EP - SET DIR(0) UP WITH SET OF CODES FOR EACH INTEGRATED SITE USING "E" X-REF ;TPF;IB*2*770v9
+1 ;
+2 NEW FACGRP,INTSITE,INSTSTATNUM,MORE,OFFNAME,STATNAME,STATNUM
+3 KILL SETOFCODES
+4 ;
+5 SET FACGRP=""
+6 ;TPF;IB*2*770v9
FOR
SET FACGRP=$ORDER(^IBA(364.99,"E",VASITE,FACGRP))
if FACGRP=""
QUIT
Begin DoDot:1
+7 SET INTSITE=$ORDER(^IBA(364.99,"C",FACGRP,0))
+8 ;="636^NWI
SET STATNUM=$PIECE($GET(^IBA(364.99,INTSITE,0)),U)
+9 ;WCJ;v10
SET INSTSTATNUM=$$RUST^IBACCROWFT(STATNUM)
+10 ;WCJ;v10 ;ICR #10090 (Supported)
SET STATIEN=$ORDER(^DIC(4,"D",INSTSTATNUM,""))
+11 if 'STATIEN
QUIT
+12 ;OFFICIAL VA NAME: VA HEALTHCARE NETWORK UPSTATE ;ICR #10090 (Supported)
SET OFFNAME=$PIECE($GET(^DIC(4,STATIEN,99)),U,3)
+13 ;ICR #10090 (Supported)
SET STATNAME=$PIECE($GET(^DIC(4,STATIEN,0)),U)_" ("_INSTSTATNUM_")"
+14 SET SETOFCODES=$GET(SETOFCODES)_FACGRP_":"_STATNAME
+15 ;TPF;IB*2*770v9
SET MORE=$ORDER(^IBA(364.99,"E",VASITE,FACGRP))
IF MORE'=""
SET SETOFCODES=SETOFCODES_";"
End DoDot:1
+16 ;TPF;IB*2*770v9
SET SETOFCODES=$GET(SETOFCODES)_";ALL:ALL AVAILABLE FACILITY GROUPS"
+17 ;
+18 QUIT
+19 ;
+20 ;VA FILEMAN V22.2 DEVELOPER'S GUIDE SECTION 2.3.47.3
+21 ;THIS IS DONE TO HANDLE USER ENTERING A THREE CHAR 'FACILITY GROUP"
SPEC(SPECINT) ;EP - SPECIAL PRE-VALIDATION TRANSFORM FOR INTEGRATED SITES
+1 ;
+2 SET SPECINT=""
+3 IF X?1"-"3A
SET SPECINT=X
SET X=""
QUIT
+4 IF X?1"-".E
IF '$DATA(IBDIV($EXTRACT(X,2,999)))
WRITE !,$EXTRACT(X,2,999)_" NOT IN CURRENT SELECTION LIST"
QUIT
+5 IF X?1"-".E
SET SPECINT=X
SET X=""
QUIT
+6 ;
+7 QUIT
