IBJPI4 ;DAOU/BHS - IBJP IIV MOST POPULAR PAYER LIST SCREEN ;25-NOV-2003
;;2.0;INTEGRATED BILLING;**271**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; IIV - Insurance Identification and Verification Interface
;
Q ; Must be called at a tag
;
ADD ; Add entry
N IBCT,IBPOS,DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y,IBNAME,IBIEN,IBI
; Refresh screen
S VALMBCK="R"
; Find highest pos in list (1-10)
S IBCT=+$O(^TMP($J,"IBJPI3-LIST",11),-1)
; Quit if count = 10
I IBCT=10 D Q
. D EN^DDIOL("Cannot add entry as all ten positions are populated!")
. D EN^DDIOL("Please modify an entry or delete an entry, if necessary!")
. D PAUSE^VALM1
; Select pos for new entry
S IBPOS=$S(IBCT=0:1,1:$$SEL(IBCT+1,"",IBCT+1)) Q:'(IBPOS>0)
; Full screen
D FULL^VALM1
; Select Payer
S IBIEN=$$PYRLKUP(IBPOS,1) Q:'(IBIEN>0)
; Quit, if dup
I $D(^TMP($J,"IBJPI3-IENS",IBIEN)) D Q
. D EN^DDIOL("Payer already in list, please try again!")
. D PAUSE^VALM1
; Add entry and shift others following down by one
F IBI=IBCT:-1:IBPOS S ^TMP($J,"IBJPI3-LIST",IBI+1)=^TMP($J,"IBJPI3-LIST",IBI)
S ^TMP($J,"IBJPI3-LIST",IBPOS)=IBIEN
S ^TMP($J,"IBJPI3-IENS",IBIEN)=""
S ^TMP($J,"IBJPI3-MODS")=""
; Kill header to force refresh
K VALMHDR
; Rebuild display
D DISP^IBJPI3
Q
;
DELETE ; Delete entry
N IBCT,IBPOS,DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y,IBNAME,IBIEN,IBI
; Refresh screen
S VALMBCK="R"
; Find highest pos in list (1-10)
S IBCT=+$O(^TMP($J,"IBJPI3-LIST",11),-1)
; Quit, if list is empty
I IBCT=0 D Q
. D EN^DDIOL("Cannot delete entry as list is empty!")
. D PAUSE^VALM1
; Select pos to delete
S IBPOS=$S(IBCT=1:1,1:$$SEL(IBCT)) Q:'(IBPOS>0)
; Display Payer Name
W " ",$E($P($G(^IBE(365.12,+$G(^TMP($J,"IBJPI3-LIST",IBPOS)),0)),U,1),1,40)
; Confirm deletion
S DIR(0)="Y"
S DIR("A")="Please confirm deletion of this entry"
S DIR("B")="NO"
D ^DIR
I $D(DIRUT)!'Y Q
; Save IEN to delete
S IBIEN=$G(^TMP($J,"IBJPI3-LIST",IBPOS))
; Shift entries in list following deleted entry up by one
F IBI=IBPOS:1:IBCT-1 S ^TMP($J,"IBJPI3-LIST",IBI)=^TMP($J,"IBJPI3-LIST",IBI+1)
K ^TMP($J,"IBJPI3-IENS",IBIEN)
K ^TMP($J,"IBJPI3-LIST",IBCT)
S ^TMP($J,"IBJPI3-MODS")=""
; Kill header to force refresh
K VALMHDR
; Build display
D DISP^IBJPI3
Q
;
MODIFY ; Modify entry
N IBCT,IBPOS,DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y,IBNAME,IBNIEN,IBOIEN,IBI
; Refresh screen
S VALMBCK="R"
; Find highest pos in list (1-10)
S IBCT=+$O(^TMP($J,"IBJPI3-LIST",11),-1)
; Quit, if list is empty
I IBCT=0 D Q
. D EN^DDIOL("Cannot modify entry as list is empty!")
. D PAUSE^VALM1
; Select pos to modify
S IBPOS=$S(IBCT=1:1,1:$$SEL(IBCT)) Q:'(IBPOS>0)
; Display Payer Name
W " ",$E($P($G(^IBE(365.12,+$G(^TMP($J,"IBJPI3-LIST",IBPOS)),0)),U,1),1,40)
; Full screen
D FULL^VALM1
; Select payer
S IBNIEN=$$PYRLKUP(IBPOS,0) Q:'(IBNIEN>0)
; Orig IEN
S IBOIEN=$G(^TMP($J,"IBJPI3-LIST",IBPOS))
I IBOIEN=IBNIEN D Q
. D EN^DDIOL("No change, please try again!")
. D PAUSE^VALM1
; Quit, if dup
I $D(^TMP($J,"IBJPI3-IENS",IBNIEN)),$G(^TMP($J,"IBJPI3-LIST",IBPOS))'=IBNIEN D Q
. D EN^DDIOL("Payer already in list, please try again!")
. D PAUSE^VALM1
; Update list and IEN index
S ^TMP($J,"IBJPI3-LIST",IBPOS)=IBNIEN
S ^TMP($J,"IBJPI3-IENS",IBNIEN)=""
; Kill orig IEN entry
K ^TMP($J,"IBJPI3-IENS",IBOIEN)
S ^TMP($J,"IBJPI3-MODS")=""
; Kill header to force refresh
K VALMHDR
; Rebuild display
D DISP^IBJPI3
Q
;
REORDER ; Reorder entry
N IBCT,IBPOS,DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y,IBNAME,IBNPOS,IBOPOS,IBI
N IBOIEN
; Refresh screen
S VALMBCK="R"
; Find highest pos in list (1-10)
S IBCT=+$O(^TMP($J,"IBJPI3-LIST",11),-1)
; Quit, if list is empty
I IBCT<2 D Q
. D EN^DDIOL("Cannot reorder entries as list is too small!")
. D PAUSE^VALM1
; Select pos to reorder
S IBOPOS=$$SEL(IBCT) Q:'(IBOPOS>0)
; Display Payer Name
W " ",$E($P($G(^IBE(365.12,+$G(^TMP($J,"IBJPI3-LIST",IBOPOS)),0)),U,1),1,40)
; Select new pos
S IBNPOS=$$SEL(IBCT,1) Q:'(IBNPOS>0)
; Quit, if no change
I IBOPOS=IBNPOS D Q
. D EN^DDIOL("New Position = Original Position, please try again!")
. D PAUSE^VALM1
; Reorder to lower pos
I IBOPOS<IBNPOS D
. ; Orig IEN
. S IBOIEN=$G(^TMP($J,"IBJPI3-LIST",IBOPOS))
. ; Shift entries following orig entry up by one
. F IBI=IBOPOS:1:IBNPOS-1 S ^TMP($J,"IBJPI3-LIST",IBI)=^TMP($J,"IBJPI3-LIST",IBI+1)
. ; Set orig IEN in new pos
. S ^TMP($J,"IBJPI3-LIST",IBNPOS)=IBOIEN
; Reorder to higher pos
I IBNPOS<IBOPOS D
. ; Save orig IEN
. S IBOIEN=$G(^TMP($J,"IBJPI3-LIST",IBOPOS))
. ; Shift entries before original entry down by one
. F IBI=IBOPOS:-1:IBNPOS+1 S ^TMP($J,"IBJPI3-LIST",IBI)=^TMP($J,"IBJPI3-LIST",IBI-1)
. ; Set orig IEN in new pos
. S ^TMP($J,"IBJPI3-LIST",IBNPOS)=IBOIEN
S ^TMP($J,"IBJPI3-MODS")=""
; Kill header to force refresh
K VALMHDR
; Rebuild display
D DISP^IBJPI3
Q
;
RESTORE ; Restore list from site params
N DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y
; Refresh screen
S VALMBCK="R"
I '$D(^TMP($J,"IBJPI3-MODS")) D Q
. D EN^DDIOL("No actions have been performed, restore unnecessary.")
. D PAUSE^VALM1
; Confirm restore
S DIR(0)="Y"
S DIR("A")="Please confirm restore of the last saved list"
S DIR("B")="NO"
D ^DIR
I $D(DIRUT)!'Y Q
; Kill header to force refresh
K VALMHDR
; Build list with site params
D BLD^IBJPI3
K ^TMP($J,"IBJPI3-MODS")
; Rebuild display
D DISP^IBJPI3
Q
;
SAVE ; Save list to Site Params file
N DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y
; Refresh screen
S VALMBCK="R"
; Temp until file is updated
;Q
I '$D(^TMP($J,"IBJPI3-MODS")) D Q
. D EN^DDIOL("No actions have been performed, save unnecessary.")
. D PAUSE^VALM1
; Confirm save to site params
S DIR(0)="Y"
S DIR("A")="Please confirm save of the current list"
S DIR("B")="NO"
D ^DIR
I $D(DIRUT)!'Y Q
; File changes
D FILE
; Kill header to force refresh
K VALMHDR
; Build list with site params
D BLD^IBJPI3
K ^TMP($J,"IBJPI3-MODS")
; Rebuild display
D DISP^IBJPI3
Q
;
FILE ; Delete orig list and file new one
; Temp until file is updated
;Q
N DIK,DA,IBCT,FDA
; Kill existing list entries
S DIK="^IBE(350.9,1,51.18,",DA(1)=1
F DA=1:1:10 I $D(^IBE(350.9,1,51.18,DA)) D ^DIK
; Loop thru list entries and update 350.9 mult fld for most pop
F IBCT=1:1:10 I $D(^TMP($J,"IBJPI3-LIST",IBCT)) S FDA(350.9003,"+1,1,",.01)=$P($G(^TMP($J,"IBJPI3-LIST",IBCT)),U,1) D UPDATE^DIE("","FDA")
; Init FDA array
K FDA
; Update List start and end dts and compile dt
S FDA(350.9,"1,",51.11)=""
S FDA(350.9,"1,",51.12)=""
S FDA(350.9,"1,",51.21)=$$NOW^XLFDT
; Save data to File (350.9)
D FILE^DIE("","FDA")
;
Q
;
SEL(MAX,NWFLG,DFLT) ; Select Position
; Input: MAX - upper bound > 0, NWFLG - opt param for 'New' prompt
; Output: -1 (time out or '^') OR n (1<=n<=MAX) OR 0
N DIR,DIRUT,DTOUT,DUOUT,IBX,X,Y
; Init output
S IBX=0
; Validate MAX
I '(MAX>0) Q IBX
; Init flag
S NWFLG=$G(NWFLG,0)
S DFLT=$G(DFLT)
; Select (New) Position
S DIR(0)="NOA^1:"_MAX_":0^K:X'>0!(X>"_MAX_") X"
S DIR("A")="Select "_$S(NWFLG:"New ",1:"")_"Position (1-"_MAX_"): "
I DFLT>0 S DIR("B")=DFLT
S DIR("?")="Please enter a valid position between 1 and "_MAX
D ^DIR
S IBX=$S($D(DIRUT):-1,+Y:+Y,1:0)
Q IBX
;
PYRLKUP(IBPOS,ADDFLG) ; Lookup Payer IEN
N DIC,DTOUT,DUOUT,X,Y,PYRIEN
;
S DIC=365.12
S DIC(0)="ABEV"
S DIC("A")="Enter Payer #"_IBPOS_": "
S DIC("?")=" Please enter a partial payer name to select a payer."
S DIC("S")="I $$PYRFLTR^IBCNEUT6"
S DIC("W")="W $$DSPLINE^IBCNEUT6"
S PYRIEN=$G(^TMP($J,"IBJPI3-LIST",IBPOS))
;
; Set default if not adding
I PYRIEN,'$G(ADDFLG) S DIC("B")=PYRIEN
D ^DIC
Q +Y
;
EXIT ; Exit action
S VALMBCK="R"
; If the list has been acted upon, prompt for save
I $D(^TMP($J,"IBJPI3-MODS")) D
. D EN^DDIOL("Unsaved changes exist!")
. D SAVE
; Call Fast Exit at this point
D FASTEXIT^IBJU1
Q
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJPI4 8115 printed Jan 19, 2023@21:37:39 Page 2
IBJPI4 ;DAOU/BHS - IBJP IIV MOST POPULAR PAYER LIST SCREEN ;25-NOV-2003
+1 ;;2.0;INTEGRATED BILLING;**271**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; IIV - Insurance Identification and Verification Interface
+5 ;
+6 ; Must be called at a tag
QUIT
+7 ;
ADD ; Add entry
+1 NEW IBCT,IBPOS,DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y,IBNAME,IBIEN,IBI
+2 ; Refresh screen
+3 SET VALMBCK="R"
+4 ; Find highest pos in list (1-10)
+5 SET IBCT=+$ORDER(^TMP($JOB,"IBJPI3-LIST",11),-1)
+6 ; Quit if count = 10
+7 IF IBCT=10
Begin DoDot:1
+8 DO EN^DDIOL("Cannot add entry as all ten positions are populated!")
+9 DO EN^DDIOL("Please modify an entry or delete an entry, if necessary!")
+10 DO PAUSE^VALM1
End DoDot:1
QUIT
+11 ; Select pos for new entry
+12 SET IBPOS=$SELECT(IBCT=0:1,1:$$SEL(IBCT+1,"",IBCT+1))
if '(IBPOS>0)
QUIT
+13 ; Full screen
+14 DO FULL^VALM1
+15 ; Select Payer
+16 SET IBIEN=$$PYRLKUP(IBPOS,1)
if '(IBIEN>0)
QUIT
+17 ; Quit, if dup
+18 IF $DATA(^TMP($JOB,"IBJPI3-IENS",IBIEN))
Begin DoDot:1
+19 DO EN^DDIOL("Payer already in list, please try again!")
+20 DO PAUSE^VALM1
End DoDot:1
QUIT
+21 ; Add entry and shift others following down by one
+22 FOR IBI=IBCT:-1:IBPOS
SET ^TMP($JOB,"IBJPI3-LIST",IBI+1)=^TMP($JOB,"IBJPI3-LIST",IBI)
+23 SET ^TMP($JOB,"IBJPI3-LIST",IBPOS)=IBIEN
+24 SET ^TMP($JOB,"IBJPI3-IENS",IBIEN)=""
+25 SET ^TMP($JOB,"IBJPI3-MODS")=""
+26 ; Kill header to force refresh
+27 KILL VALMHDR
+28 ; Rebuild display
+29 DO DISP^IBJPI3
+30 QUIT
+31 ;
DELETE ; Delete entry
+1 NEW IBCT,IBPOS,DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y,IBNAME,IBIEN,IBI
+2 ; Refresh screen
+3 SET VALMBCK="R"
+4 ; Find highest pos in list (1-10)
+5 SET IBCT=+$ORDER(^TMP($JOB,"IBJPI3-LIST",11),-1)
+6 ; Quit, if list is empty
+7 IF IBCT=0
Begin DoDot:1
+8 DO EN^DDIOL("Cannot delete entry as list is empty!")
+9 DO PAUSE^VALM1
End DoDot:1
QUIT
+10 ; Select pos to delete
+11 SET IBPOS=$SELECT(IBCT=1:1,1:$$SEL(IBCT))
if '(IBPOS>0)
QUIT
+12 ; Display Payer Name
+13 WRITE " ",$EXTRACT($PIECE($GET(^IBE(365.12,+$GET(^TMP($JOB,"IBJPI3-LIST",IBPOS)),0)),U,1),1,40)
+14 ; Confirm deletion
+15 SET DIR(0)="Y"
+16 SET DIR("A")="Please confirm deletion of this entry"
+17 SET DIR("B")="NO"
+18 DO ^DIR
+19 IF $DATA(DIRUT)!'Y
QUIT
+20 ; Save IEN to delete
+21 SET IBIEN=$GET(^TMP($JOB,"IBJPI3-LIST",IBPOS))
+22 ; Shift entries in list following deleted entry up by one
+23 FOR IBI=IBPOS:1:IBCT-1
SET ^TMP($JOB,"IBJPI3-LIST",IBI)=^TMP($JOB,"IBJPI3-LIST",IBI+1)
+24 KILL ^TMP($JOB,"IBJPI3-IENS",IBIEN)
+25 KILL ^TMP($JOB,"IBJPI3-LIST",IBCT)
+26 SET ^TMP($JOB,"IBJPI3-MODS")=""
+27 ; Kill header to force refresh
+28 KILL VALMHDR
+29 ; Build display
+30 DO DISP^IBJPI3
+31 QUIT
+32 ;
MODIFY ; Modify entry
+1 NEW IBCT,IBPOS,DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y,IBNAME,IBNIEN,IBOIEN,IBI
+2 ; Refresh screen
+3 SET VALMBCK="R"
+4 ; Find highest pos in list (1-10)
+5 SET IBCT=+$ORDER(^TMP($JOB,"IBJPI3-LIST",11),-1)
+6 ; Quit, if list is empty
+7 IF IBCT=0
Begin DoDot:1
+8 DO EN^DDIOL("Cannot modify entry as list is empty!")
+9 DO PAUSE^VALM1
End DoDot:1
QUIT
+10 ; Select pos to modify
+11 SET IBPOS=$SELECT(IBCT=1:1,1:$$SEL(IBCT))
if '(IBPOS>0)
QUIT
+12 ; Display Payer Name
+13 WRITE " ",$EXTRACT($PIECE($GET(^IBE(365.12,+$GET(^TMP($JOB,"IBJPI3-LIST",IBPOS)),0)),U,1),1,40)
+14 ; Full screen
+15 DO FULL^VALM1
+16 ; Select payer
+17 SET IBNIEN=$$PYRLKUP(IBPOS,0)
if '(IBNIEN>0)
QUIT
+18 ; Orig IEN
+19 SET IBOIEN=$GET(^TMP($JOB,"IBJPI3-LIST",IBPOS))
+20 IF IBOIEN=IBNIEN
Begin DoDot:1
+21 DO EN^DDIOL("No change, please try again!")
+22 DO PAUSE^VALM1
End DoDot:1
QUIT
+23 ; Quit, if dup
+24 IF $DATA(^TMP($JOB,"IBJPI3-IENS",IBNIEN))
IF $GET(^TMP($JOB,"IBJPI3-LIST",IBPOS))'=IBNIEN
Begin DoDot:1
+25 DO EN^DDIOL("Payer already in list, please try again!")
+26 DO PAUSE^VALM1
End DoDot:1
QUIT
+27 ; Update list and IEN index
+28 SET ^TMP($JOB,"IBJPI3-LIST",IBPOS)=IBNIEN
+29 SET ^TMP($JOB,"IBJPI3-IENS",IBNIEN)=""
+30 ; Kill orig IEN entry
+31 KILL ^TMP($JOB,"IBJPI3-IENS",IBOIEN)
+32 SET ^TMP($JOB,"IBJPI3-MODS")=""
+33 ; Kill header to force refresh
+34 KILL VALMHDR
+35 ; Rebuild display
+36 DO DISP^IBJPI3
+37 QUIT
+38 ;
REORDER ; Reorder entry
+1 NEW IBCT,IBPOS,DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y,IBNAME,IBNPOS,IBOPOS,IBI
+2 NEW IBOIEN
+3 ; Refresh screen
+4 SET VALMBCK="R"
+5 ; Find highest pos in list (1-10)
+6 SET IBCT=+$ORDER(^TMP($JOB,"IBJPI3-LIST",11),-1)
+7 ; Quit, if list is empty
+8 IF IBCT<2
Begin DoDot:1
+9 DO EN^DDIOL("Cannot reorder entries as list is too small!")
+10 DO PAUSE^VALM1
End DoDot:1
QUIT
+11 ; Select pos to reorder
+12 SET IBOPOS=$$SEL(IBCT)
if '(IBOPOS>0)
QUIT
+13 ; Display Payer Name
+14 WRITE " ",$EXTRACT($PIECE($GET(^IBE(365.12,+$GET(^TMP($JOB,"IBJPI3-LIST",IBOPOS)),0)),U,1),1,40)
+15 ; Select new pos
+16 SET IBNPOS=$$SEL(IBCT,1)
if '(IBNPOS>0)
QUIT
+17 ; Quit, if no change
+18 IF IBOPOS=IBNPOS
Begin DoDot:1
+19 DO EN^DDIOL("New Position = Original Position, please try again!")
+20 DO PAUSE^VALM1
End DoDot:1
QUIT
+21 ; Reorder to lower pos
+22 IF IBOPOS<IBNPOS
Begin DoDot:1
+23 ; Orig IEN
+24 SET IBOIEN=$GET(^TMP($JOB,"IBJPI3-LIST",IBOPOS))
+25 ; Shift entries following orig entry up by one
+26 FOR IBI=IBOPOS:1:IBNPOS-1
SET ^TMP($JOB,"IBJPI3-LIST",IBI)=^TMP($JOB,"IBJPI3-LIST",IBI+1)
+27 ; Set orig IEN in new pos
+28 SET ^TMP($JOB,"IBJPI3-LIST",IBNPOS)=IBOIEN
End DoDot:1
+29 ; Reorder to higher pos
+30 IF IBNPOS<IBOPOS
Begin DoDot:1
+31 ; Save orig IEN
+32 SET IBOIEN=$GET(^TMP($JOB,"IBJPI3-LIST",IBOPOS))
+33 ; Shift entries before original entry down by one
+34 FOR IBI=IBOPOS:-1:IBNPOS+1
SET ^TMP($JOB,"IBJPI3-LIST",IBI)=^TMP($JOB,"IBJPI3-LIST",IBI-1)
+35 ; Set orig IEN in new pos
+36 SET ^TMP($JOB,"IBJPI3-LIST",IBNPOS)=IBOIEN
End DoDot:1
+37 SET ^TMP($JOB,"IBJPI3-MODS")=""
+38 ; Kill header to force refresh
+39 KILL VALMHDR
+40 ; Rebuild display
+41 DO DISP^IBJPI3
+42 QUIT
+43 ;
RESTORE ; Restore list from site params
+1 NEW DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y
+2 ; Refresh screen
+3 SET VALMBCK="R"
+4 IF '$DATA(^TMP($JOB,"IBJPI3-MODS"))
Begin DoDot:1
+5 DO EN^DDIOL("No actions have been performed, restore unnecessary.")
+6 DO PAUSE^VALM1
End DoDot:1
QUIT
+7 ; Confirm restore
+8 SET DIR(0)="Y"
+9 SET DIR("A")="Please confirm restore of the last saved list"
+10 SET DIR("B")="NO"
+11 DO ^DIR
+12 IF $DATA(DIRUT)!'Y
QUIT
+13 ; Kill header to force refresh
+14 KILL VALMHDR
+15 ; Build list with site params
+16 DO BLD^IBJPI3
+17 KILL ^TMP($JOB,"IBJPI3-MODS")
+18 ; Rebuild display
+19 DO DISP^IBJPI3
+20 QUIT
+21 ;
SAVE ; Save list to Site Params file
+1 NEW DIR,DIRUT,DTOUT,DUOUT,DIROUT,X,Y
+2 ; Refresh screen
+3 SET VALMBCK="R"
+4 ; Temp until file is updated
+5 ;Q
+6 IF '$DATA(^TMP($JOB,"IBJPI3-MODS"))
Begin DoDot:1
+7 DO EN^DDIOL("No actions have been performed, save unnecessary.")
+8 DO PAUSE^VALM1
End DoDot:1
QUIT
+9 ; Confirm save to site params
+10 SET DIR(0)="Y"
+11 SET DIR("A")="Please confirm save of the current list"
+12 SET DIR("B")="NO"
+13 DO ^DIR
+14 IF $DATA(DIRUT)!'Y
QUIT
+15 ; File changes
+16 DO FILE
+17 ; Kill header to force refresh
+18 KILL VALMHDR
+19 ; Build list with site params
+20 DO BLD^IBJPI3
+21 KILL ^TMP($JOB,"IBJPI3-MODS")
+22 ; Rebuild display
+23 DO DISP^IBJPI3
+24 QUIT
+25 ;
FILE ; Delete orig list and file new one
+1 ; Temp until file is updated
+2 ;Q
+3 NEW DIK,DA,IBCT,FDA
+4 ; Kill existing list entries
+5 SET DIK="^IBE(350.9,1,51.18,"
SET DA(1)=1
+6 FOR DA=1:1:10
IF $DATA(^IBE(350.9,1,51.18,DA))
DO ^DIK
+7 ; Loop thru list entries and update 350.9 mult fld for most pop
+8 FOR IBCT=1:1:10
IF $DATA(^TMP($JOB,"IBJPI3-LIST",IBCT))
SET FDA(350.9003,"+1,1,",.01)=$PIECE($GET(^TMP($JOB,"IBJPI3-LIST",IBCT)),U,1)
DO UPDATE^DIE("","FDA")
+9 ; Init FDA array
+10 KILL FDA
+11 ; Update List start and end dts and compile dt
+12 SET FDA(350.9,"1,",51.11)=""
+13 SET FDA(350.9,"1,",51.12)=""
+14 SET FDA(350.9,"1,",51.21)=$$NOW^XLFDT
+15 ; Save data to File (350.9)
+16 DO FILE^DIE("","FDA")
+17 ;
+18 QUIT
+19 ;
SEL(MAX,NWFLG,DFLT) ; Select Position
+1 ; Input: MAX - upper bound > 0, NWFLG - opt param for 'New' prompt
+2 ; Output: -1 (time out or '^') OR n (1<=n<=MAX) OR 0
+3 NEW DIR,DIRUT,DTOUT,DUOUT,IBX,X,Y
+4 ; Init output
+5 SET IBX=0
+6 ; Validate MAX
+7 IF '(MAX>0)
QUIT IBX
+8 ; Init flag
+9 SET NWFLG=$GET(NWFLG,0)
+10 SET DFLT=$GET(DFLT)
+11 ; Select (New) Position
+12 SET DIR(0)="NOA^1:"_MAX_":0^K:X'>0!(X>"_MAX_") X"
+13 SET DIR("A")="Select "_$SELECT(NWFLG:"New ",1:"")_"Position (1-"_MAX_"): "
+14 IF DFLT>0
SET DIR("B")=DFLT
+15 SET DIR("?")="Please enter a valid position between 1 and "_MAX
+16 DO ^DIR
+17 SET IBX=$SELECT($DATA(DIRUT):-1,+Y:+Y,1:0)
+18 QUIT IBX
+19 ;
PYRLKUP(IBPOS,ADDFLG) ; Lookup Payer IEN
+1 NEW DIC,DTOUT,DUOUT,X,Y,PYRIEN
+2 ;
+3 SET DIC=365.12
+4 SET DIC(0)="ABEV"
+5 SET DIC("A")="Enter Payer #"_IBPOS_": "
+6 SET DIC("?")=" Please enter a partial payer name to select a payer."
+7 SET DIC("S")="I $$PYRFLTR^IBCNEUT6"
+8 SET DIC("W")="W $$DSPLINE^IBCNEUT6"
+9 SET PYRIEN=$GET(^TMP($JOB,"IBJPI3-LIST",IBPOS))
+10 ;
+11 ; Set default if not adding
+12 IF PYRIEN
IF '$GET(ADDFLG)
SET DIC("B")=PYRIEN
+13 DO ^DIC
+14 QUIT +Y
+15 ;
EXIT ; Exit action
+1 SET VALMBCK="R"
+2 ; If the list has been acted upon, prompt for save
+3 IF $DATA(^TMP($JOB,"IBJPI3-MODS"))
Begin DoDot:1
+4 DO EN^DDIOL("Unsaved changes exist!")
+5 DO SAVE
End DoDot:1
+6 ; Call Fast Exit at this point
+7 DO FASTEXIT^IBJU1
+8 QUIT
+9 ;
+10 ;
