IBJPI3 ;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
;
EN ; -- main entry pt for IBJP IIV MOST POPULAR PAYERS
N POP,X,CTRLCOL,VALMHDR,VALMCNT,%DT
D EN^VALM("IBJP IIV MOST POPULAR PAYERS")
Q
;
HDR ; -- header code
S VALMHDR(1)=" "_$S($D(^TMP($J,"IBJPI3-MODS")):"Unsaved Changes Exist",1:"Last Saved: "_$$FMTE^XLFDT($P($G(^IBE(350.9,1,51)),U,21),"5Z"))
S VALMHDR(2)=" "_$$FO^IBCNEUT1(" ",49)_" "_$$FO^IBCNEUT1(" ",11)_" Nat. Loc."
S VALMHDR(3)=" # "_$$FO^IBCNEUT1("Payer Name ",49)_" "_$$FO^IBCNEUT1("National ID",11)_" Act? Act?"
Q
;
INIT ; -- init vars and list array
; Init temp globals
K ^TMP($J,"IBJPI3")
K ^TMP($J,"IBJPI3-IENS")
K ^TMP($J,"IBJPI3-LIST")
K ^TMP($J,"IBJPI3-MODS")
D CLEAN^VALM10 ; Kills data and video control arrays w/active list
D BLD ; Build list from site params
D DISP ; Build display array
Q
;
HELP ; HELP screen for Most Pop screen
D FULL^VALM1 ; Full screen mode
W @IOF
D EN^DDIOL("Most Popular Payer List Edit Actions")
D EN^DDIOL(" ")
D EN^DDIOL("Add Entry - Inserts a new payer into the list at any position as")
D EN^DDIOL(" long as the list has fewer than ten entries. The entry will be inserted and")
D EN^DDIOL(" existing entries from the new position through the end of the list will be")
D EN^DDIOL(" shifted down one position.")
D EN^DDIOL(" ")
D EN^DDIOL("Delete Entry - Deletes a payer from the list at any position as")
D EN^DDIOL(" long as the list has at least one entry. The entries following the deleted")
D EN^DDIOL(" entry will be shifted up one position.")
D EN^DDIOL(" ")
D EN^DDIOL("Modify Entry - Modifies a payer from the list at any position as")
D EN^DDIOL(" long as the list has at least one entry. The new payer must be")
D EN^DDIOL(" valid in order to replace the existing entry.")
D EN^DDIOL(" ")
D EN^DDIOL("Print Current List - Allows the user to specify a device and print the current")
D EN^DDIOL(" items in the list.")
D PAUSE^VALM1
D EN^DDIOL("Reorder Entry - Changes a payer from the list at any position to")
D EN^DDIOL(" another position so long as the list has at least two entries. Moving the")
D EN^DDIOL(" entry to a lower position shifts entries following the original position up")
D EN^DDIOL(" one position except for those lower than the new position. Moving the entry")
D EN^DDIOL(" to a higher position shifts entries following the new position down one")
D EN^DDIOL(" position except for those lower than the original position.")
D EN^DDIOL(" ")
D EN^DDIOL("Restore Saved List - If editing actions were performed, the user will be")
D EN^DDIOL(" prompted to verify that they wish to discard all changes.")
D EN^DDIOL(" ")
D EN^DDIOL("Save Current List - Saves the current list to the Site Parameters file.")
D EN^DDIOL(" ")
D EN^DDIOL("Exit Action - If editing actions were performed, the user will be prompted")
D EN^DDIOL(" to save the current list or exit without filing changes.")
D PAUSE^VALM1 ; Press return to continue
W @IOF
S VALMBCK="R" ; Refresh screen
Q
;
EXIT ; -- exit code
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^IBJPI4
; Kill temp globals
K ^TMP($J,"IBJPI3")
K ^TMP($J,"IBJPI3-LIST")
K ^TMP($J,"IBJPI3-IENS")
K ^TMP($J,"IBJPI3-MODS")
D CLEAN^VALM10 ; Kills data and video control arrays w/active list
Q
;
BLD ; -- build list array
N IBIEN,IBCT,IEN
; Init temp globals
K ^TMP($J,"IBJPI3-LIST")
K ^TMP($J,"IBJPI3-IENS")
K ^TMP($J,"IBJPI3-MODS")
; Loop thru current List of Payers
S (IEN,IBCT)=0
F S IEN=$O(^IBE(350.9,1,51.18,IEN)) Q:'IEN D
. S IBIEN=$P($G(^IBE(350.9,1,51.18,IEN,0)),U) Q:'IBIEN ; Bad IEN
. S IBCT=IBCT+1
. S ^TMP($J,"IBJPI3-LIST",IBCT)=IBIEN ; List by pos
. S ^TMP($J,"IBJPI3-IENS",IBIEN)="" ; IEN index
Q
;
DISP ; Build display array of text
N IBI,IBIEN,IBST,IBLN,IBAIEN,IBADATA
; Init display global
K ^TMP($J,"IBJPI3")
; Loop thru current list of Payers
S IBLN=0
F IBI=1:1:10 S IBIEN=$G(^TMP($J,"IBJPI3-LIST",IBI)) Q:'IBIEN D
. S IBST=$$FO^IBCNEUT1(IBI,3,"R")_". "
. ; Name
. S IBST=IBST_$$FO^IBCNEUT1($P($G(^IBE(365.12,IBIEN,0)),U),49)
. ; National ID
. S IBST=IBST_" "_$$FO^IBCNEUT1($P($G(^IBE(365.12,IBIEN,0)),U,2),11)
. S (IBAIEN,IBADATA)=""
. ; Payer App IEN
. S IBAIEN=$$PYRAPP^IBCNEUT5("IIV",IBIEN)
. ; WARNING - IIV application does not exist
. I IBAIEN="" D Q
. . S IBLN=$$SET(IBLN,IBST)
. . S IBST=" ** Please remove from this list: Payer not configured for IIV **"
. . S IBLN=$$SET(IBLN,IBST)
. S IBADATA=$G(^IBE(365.12,+IBIEN,1,+IBAIEN,0))
. ; Nat Act Flg
. S IBST=IBST_" "_$$FO^IBCNEUT1($S('$P(IBADATA,U,2):"NO",1:"YES"),4)
. ; Loc Act Flg
. S IBST=IBST_" "_$$FO^IBCNEUT1($S('$P(IBADATA,U,3):"NO",1:"YES"),4)
. S IBLN=$$SET(IBLN,IBST)
. ; WARNING - IIV application deactivated
. I +$P(IBADATA,U,11) D Q
. . S IBST=" ** Please remove from this list: Payer is deactivated for IIV **"
. . S IBLN=$$SET(IBLN,IBST)
. ; WARNING - Id Inq Req ID = YES & Use SSN as ID = NO
. I +$P(IBADATA,U,8),'$P(IBADATA,U,9) D
. . S IBST=" ** Please remove from this list: Inquiries w/o subscriber ID rejected **"
. . S IBLN=$$SET(IBLN,IBST)
; No Data Found if $O(^TMP($J,"IBJPI3-LIST",0))=""
I $O(^TMP($J,"IBJPI3-LIST",0))="" S IBLN=$$SET(IBLN," *** NO DATA FOUND!!! ***")
; Update line ct
S VALMCNT=IBLN
Q
;
SET(LN,STR) ; Build list array
S LN=$G(LN)+1
D SET^VALM10(LN,STR)
Q LN
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJPI3 5850 printed Apr 07, 2021@15:35:22 Page 2
IBJPI3 ;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 ;
EN ; -- main entry pt for IBJP IIV MOST POPULAR PAYERS
+1 NEW POP,X,CTRLCOL,VALMHDR,VALMCNT,%DT
+2 DO EN^VALM("IBJP IIV MOST POPULAR PAYERS")
+3 QUIT
+4 ;
HDR ; -- header code
+1 SET VALMHDR(1)=" "_$SELECT($DATA(^TMP($JOB,"IBJPI3-MODS")):"Unsaved Changes Exist",1:"Last Saved: "_$$FMTE^XLFDT($PIECE($GET(^IBE(350.9,1,51)),U,21),"5Z"))
+2 SET VALMHDR(2)=" "_$$FO^IBCNEUT1(" ",49)_" "_$$FO^IBCNEUT1(" ",11)_" Nat. Loc."
+3 SET VALMHDR(3)=" # "_$$FO^IBCNEUT1("Payer Name ",49)_" "_$$FO^IBCNEUT1("National ID",11)_" Act? Act?"
+4 QUIT
+5 ;
INIT ; -- init vars and list array
+1 ; Init temp globals
+2 KILL ^TMP($JOB,"IBJPI3")
+3 KILL ^TMP($JOB,"IBJPI3-IENS")
+4 KILL ^TMP($JOB,"IBJPI3-LIST")
+5 KILL ^TMP($JOB,"IBJPI3-MODS")
+6 ; Kills data and video control arrays w/active list
DO CLEAN^VALM10
+7 ; Build list from site params
DO BLD
+8 ; Build display array
DO DISP
+9 QUIT
+10 ;
HELP ; HELP screen for Most Pop screen
+1 ; Full screen mode
DO FULL^VALM1
+2 WRITE @IOF
+3 DO EN^DDIOL("Most Popular Payer List Edit Actions")
+4 DO EN^DDIOL(" ")
+5 DO EN^DDIOL("Add Entry - Inserts a new payer into the list at any position as")
+6 DO EN^DDIOL(" long as the list has fewer than ten entries. The entry will be inserted and")
+7 DO EN^DDIOL(" existing entries from the new position through the end of the list will be")
+8 DO EN^DDIOL(" shifted down one position.")
+9 DO EN^DDIOL(" ")
+10 DO EN^DDIOL("Delete Entry - Deletes a payer from the list at any position as")
+11 DO EN^DDIOL(" long as the list has at least one entry. The entries following the deleted")
+12 DO EN^DDIOL(" entry will be shifted up one position.")
+13 DO EN^DDIOL(" ")
+14 DO EN^DDIOL("Modify Entry - Modifies a payer from the list at any position as")
+15 DO EN^DDIOL(" long as the list has at least one entry. The new payer must be")
+16 DO EN^DDIOL(" valid in order to replace the existing entry.")
+17 DO EN^DDIOL(" ")
+18 DO EN^DDIOL("Print Current List - Allows the user to specify a device and print the current")
+19 DO EN^DDIOL(" items in the list.")
+20 DO PAUSE^VALM1
+21 DO EN^DDIOL("Reorder Entry - Changes a payer from the list at any position to")
+22 DO EN^DDIOL(" another position so long as the list has at least two entries. Moving the")
+23 DO EN^DDIOL(" entry to a lower position shifts entries following the original position up")
+24 DO EN^DDIOL(" one position except for those lower than the new position. Moving the entry")
+25 DO EN^DDIOL(" to a higher position shifts entries following the new position down one")
+26 DO EN^DDIOL(" position except for those lower than the original position.")
+27 DO EN^DDIOL(" ")
+28 DO EN^DDIOL("Restore Saved List - If editing actions were performed, the user will be")
+29 DO EN^DDIOL(" prompted to verify that they wish to discard all changes.")
+30 DO EN^DDIOL(" ")
+31 DO EN^DDIOL("Save Current List - Saves the current list to the Site Parameters file.")
+32 DO EN^DDIOL(" ")
+33 DO EN^DDIOL("Exit Action - If editing actions were performed, the user will be prompted")
+34 DO EN^DDIOL(" to save the current list or exit without filing changes.")
+35 ; Press return to continue
DO PAUSE^VALM1
+36 WRITE @IOF
+37 ; Refresh screen
SET VALMBCK="R"
+38 QUIT
+39 ;
EXIT ; -- exit code
+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^IBJPI4
End DoDot:1
+6 ; Kill temp globals
+7 KILL ^TMP($JOB,"IBJPI3")
+8 KILL ^TMP($JOB,"IBJPI3-LIST")
+9 KILL ^TMP($JOB,"IBJPI3-IENS")
+10 KILL ^TMP($JOB,"IBJPI3-MODS")
+11 ; Kills data and video control arrays w/active list
DO CLEAN^VALM10
+12 QUIT
+13 ;
BLD ; -- build list array
+1 NEW IBIEN,IBCT,IEN
+2 ; Init temp globals
+3 KILL ^TMP($JOB,"IBJPI3-LIST")
+4 KILL ^TMP($JOB,"IBJPI3-IENS")
+5 KILL ^TMP($JOB,"IBJPI3-MODS")
+6 ; Loop thru current List of Payers
+7 SET (IEN,IBCT)=0
+8 FOR
SET IEN=$ORDER(^IBE(350.9,1,51.18,IEN))
if 'IEN
QUIT
Begin DoDot:1
+9 ; Bad IEN
SET IBIEN=$PIECE($GET(^IBE(350.9,1,51.18,IEN,0)),U)
if 'IBIEN
QUIT
+10 SET IBCT=IBCT+1
+11 ; List by pos
SET ^TMP($JOB,"IBJPI3-LIST",IBCT)=IBIEN
+12 ; IEN index
SET ^TMP($JOB,"IBJPI3-IENS",IBIEN)=""
End DoDot:1
+13 QUIT
+14 ;
DISP ; Build display array of text
+1 NEW IBI,IBIEN,IBST,IBLN,IBAIEN,IBADATA
+2 ; Init display global
+3 KILL ^TMP($JOB,"IBJPI3")
+4 ; Loop thru current list of Payers
+5 SET IBLN=0
+6 FOR IBI=1:1:10
SET IBIEN=$GET(^TMP($JOB,"IBJPI3-LIST",IBI))
if 'IBIEN
QUIT
Begin DoDot:1
+7 SET IBST=$$FO^IBCNEUT1(IBI,3,"R")_". "
+8 ; Name
+9 SET IBST=IBST_$$FO^IBCNEUT1($PIECE($GET(^IBE(365.12,IBIEN,0)),U),49)
+10 ; National ID
+11 SET IBST=IBST_" "_$$FO^IBCNEUT1($PIECE($GET(^IBE(365.12,IBIEN,0)),U,2),11)
+12 SET (IBAIEN,IBADATA)=""
+13 ; Payer App IEN
+14 SET IBAIEN=$$PYRAPP^IBCNEUT5("IIV",IBIEN)
+15 ; WARNING - IIV application does not exist
+16 IF IBAIEN=""
Begin DoDot:2
+17 SET IBLN=$$SET(IBLN,IBST)
+18 SET IBST=" ** Please remove from this list: Payer not configured for IIV **"
+19 SET IBLN=$$SET(IBLN,IBST)
End DoDot:2
QUIT
+20 SET IBADATA=$GET(^IBE(365.12,+IBIEN,1,+IBAIEN,0))
+21 ; Nat Act Flg
+22 SET IBST=IBST_" "_$$FO^IBCNEUT1($SELECT('$PIECE(IBADATA,U,2):"NO",1:"YES"),4)
+23 ; Loc Act Flg
+24 SET IBST=IBST_" "_$$FO^IBCNEUT1($SELECT('$PIECE(IBADATA,U,3):"NO",1:"YES"),4)
+25 SET IBLN=$$SET(IBLN,IBST)
+26 ; WARNING - IIV application deactivated
+27 IF +$PIECE(IBADATA,U,11)
Begin DoDot:2
+28 SET IBST=" ** Please remove from this list: Payer is deactivated for IIV **"
+29 SET IBLN=$$SET(IBLN,IBST)
End DoDot:2
QUIT
+30 ; WARNING - Id Inq Req ID = YES & Use SSN as ID = NO
+31 IF +$PIECE(IBADATA,U,8)
IF '$PIECE(IBADATA,U,9)
Begin DoDot:2
+32 SET IBST=" ** Please remove from this list: Inquiries w/o subscriber ID rejected **"
+33 SET IBLN=$$SET(IBLN,IBST)
End DoDot:2
End DoDot:1
+34 ; No Data Found if $O(^TMP($J,"IBJPI3-LIST",0))=""
+35 IF $ORDER(^TMP($JOB,"IBJPI3-LIST",0))=""
SET IBLN=$$SET(IBLN," *** NO DATA FOUND!!! ***")
+36 ; Update line ct
+37 SET VALMCNT=IBLN
+38 QUIT
+39 ;
SET(LN,STR) ; Build list array
+1 SET LN=$GET(LN)+1
+2 DO SET^VALM10(LN,STR)
+3 QUIT LN
+4 ;
