IBJPS6 ;ALB/WCJ - IB Site Parameters, Administrative Contractors ; 27-AUG-2015
;;2.0;INTEGRATED BILLING;**547**;21-MAR-94;Build 119
;;Per VA Directive 6402, this routine should not be modified.
;;
;
Q
;
EN(WHICH) ; -- main entry point for IBJP ALT PRIM PAYER ID TYP
; Input: WHICH - 1 - Using template IBJP ADMIN CONTRACTOR MED
; 2 - Using template IBJP ADMIN CONTRACTOR COM
N TEMPLATE
S TEMPLATE=$S(WHICH=1:"IBJP ADMIN CONTRACTOR MED",1:"IBJP ADMIN CONTRACTOR COM")
D EN^VALM(TEMPLATE)
Q
;
HDR(WHICH) ; -- header code
; Input: WHICH - 1 - Using template IBJP ADMIN CONTRACTOR MED
; 2 - Using template IBJP ADMIN CONTRACTOR COM
;
S:WHICH=1 VALMHDR(1)="Medicare"
S:WHICH=2 VALMHDR(1)="Commercial"
Q
;
INIT(WHICH) ; Initialize variables and list array
; Input: WHICH - 1 - Using template IBJP ADMIN CONTRACTOR MED
; 2 - Using template IBJP ADMIN CONTRACTOR COM
; Output: ^TMP("IBJPS6",$J) - Body lines to display for specified template
K ^TMP("IBJPS6",$J),^TMP($J,"IBJPS6IX")
D BLD(WHICH)
Q
;
BLD(WHICH) ; Build screen array, no variables required for input
; Input: WHICH - 1 - Using template IBJP ADMIN CONTRACTOR MED
; 2 - Using template IBJP ADMIN CONTRACTOR COM
; Output: ^TMP("IBJPS6",$J) - Body lines to display for specified template
;
N CNT,ENTRIES,LINE,NAME,NAMEIEN,NODE,NODE0,Z
S VALMCNT=0
S NODE=$S(WHICH=1:81,1:82)
S (Z,CNT)=0
F D Q:+Z=0
. S Z=$O(^IBE(350.9,1,NODE,Z))
. Q:+Z=0
. S NODE0=$G(^IBE(350.9,1,NODE,Z,0)),NAMEIEN=+$P(NODE0,U,1)
. I NAMEIEN>0 D
. . S CNT=CNT+1,NAME=$$EXTERNAL^DILFD(350.9_NODE,.01,"",NAMEIEN)
. . I NAME'="" D
. . . S ENTRIES(NAME,CNT)=NAMEIEN,ENTRIES(NAME,CNT,"IEN")=Z
I '$D(ENTRIES) D Q
. S LINE=$$SETL("","","** No entries found **",29,22)
. S ^TMP("IBJPS6",$J,1,0)=LINE
;
S NAME=""
F D Q:NAME=""
.S NAME=$O(ENTRIES(NAME)) Q:NAME=""
.S Z=0 F D Q:Z=""
..S Z=$O(ENTRIES(NAME,Z)) Q:Z=""
..S VALMCNT=VALMCNT+1
..S LINE=$$BLDLN(VALMCNT,NAME,ENTRIES(NAME,Z))
..D SET^VALM10(VALMCNT,LINE,VALMCNT)
..S ^TMP($J,"IBJPS6IX",VALMCNT)=ENTRIES(NAME,Z,"IEN")
..Q
.Q
Q
;
BLDLN(CTR,NAME,IEN) ; Builds a line to display and insurance
; Input: CTR - Current Line Counter
; NAME - Insurance Company Name
; IEN - IEN of the insurance to be displayed
; Output: LINE - Formatted for settng into the list display
N LINE,XX
S LINE=$$SETSTR^VALM1(CTR,"",1,4) ; Entry #
S LINE=$$SETSTR^VALM1(NAME,LINE,6,66) ; Administrative Contractor Type
Q LINE
;
SETL(LINE,DATA,LABEL,COL,LNG) ; Creates a line of data to be set into the body
; of the worklist
; Input: LINE - Current line being created
; DATA - Information to be added to the end of the current line
; LABEL - Label to describe the information being added
; COL - Column position in line to add information add
; LNG - Maximum length of data information to include on the line
; Returns: Line updated with added information
S LINE=LINE_$J("",(COL-$L(LABEL)-$L(LINE)))_LABEL_$E(DATA,1,LNG)
Q LINE
;
HELP(WHICH) ; -- help code
; Input: WHICH - 1 - Using template IBJP ADMIN CONTRACTOR MED
; 2 - Using template IBJP ADMIN CONTRACTOR COM
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT(WHICH) ; Exit code
; Input: WHICH - 1 - Using template IBJP ADMIN CONTRACTOR MED
; 2 - Using template IBJP ADMIN CONTRACTOR COM
K ^TMP("IBJPS6",$J),^TMP($J,"IBJPS6IX")
D CLEAR^VALM1
Q
;
EXPND ; -- expand code
Q
;
ADD(WHICH) ; Listman Protocol Action to add an entry to the specified Site Parameter node
; Input: WHICH - 1 - Using template IBJP ADMIN CONTRACTOR MED
; 2 - Using template IBJP ADMIN CONTRACTOR COM
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,FDA,IEN,IENS,INSM,INSMC
N NODE,NAME,NAMEU,NODE0,X,XX,Y,Z,Z1
S NODE=$S(WHICH=1:81,1:82)
S VALMBCK="R" ; Refresh screen on return
Q:'$$LOCK(NODE) ; Couldn't lock for adding
D FULL^VALM1
;
I '$$ENTSEL(NODE,.IENS,WHICH) D Q ; Select entry(s) to be added
. S VALMSG="No Primary ID Types selected"
. D UNLOCK(NODE)
;
; Add the selected entries into the list
S IEN=""
F D Q:IEN=""
. S IEN=$O(IENS(IEN))
. Q:IEN=""
. Q:$$FIND1^DIC("350.9"_NODE,",1,","QX",IEN) ; don't add it, it's already there.
. S FDA("350.9"_NODE,"+1,1,",.01)=IEN
. D UPDATE^DIE("","FDA")
D UNLOCK(NODE) ; Unlock the Node
;
D INIT(WHICH) ; Rebuild list body
S VALMSG="Added Primary ID Types"
Q
;
DEL(WHICH) ; Listman Protocol Action to delete an entry from the specified Site Parameter node
; Input: WHICH - 1 - Using template IBJP ADMIN CONTRACTOR MED
; 2 - Using template IBJP ADMIN CONTRACTOR COM
;
N CNT,CNT2,DA,DIK,DIR,DIROUT,DIRUT,DTOUT,DUOUT,LIST,NAME
N NODE,NODE0,SELSTR,STR,X,XX,Y,Z,Z1,OTHER,SKIPPED,DELETED
S NODE=$S(WHICH=1:81,1:82)
S OTHER=$S(NODE=82:81,1:82)
S VALMBCK="R" ; Refresh screen on return
Q:'$$LOCK(NODE) ; Couldn't lock for deletion
D FULL^VALM1 ; Display warning message
S STR=$$SELEVENT(0,"",.SELSTR,1,"IBJPS6IX")
;
I STR="" D Q ; Select entry(s) to be added
. S VALMSG="No Pimary ID Types selected"
. S VALMBCK="R" ; resetting this variable which disappeared to refresh screen
. D UNLOCK(NODE)
;
I STR'="" D
. F Z=1:1:$L(STR,",") D
. . S Z1=$P(STR,",",Z),NODE0=$G(^IBE(350.9,1,NODE,Z1,0))
. . S NAME=$$EXTERNAL^DILFD(350.9_NODE,.01,"",+$P(NODE0,"^",1))
. . S LIST(Z1)=NAME
. . S LIST(Z1,"I")=+NODE0
;
; Delete the selected entries from the list
S DA(1)=1,(CNT,CNT2,DA)=0
S SKIPPED=""
F S DA=$O(LIST(DA)) Q:'DA D
. I $D(^DIC(36,"AB",LIST(DA,"I")))!($D(^DIC(36,"AD",LIST(DA,"I")))),'$D(^IBE(350.9,1,OTHER,"B",LIST(DA,"I"))) D Q ; don't let them delete ones in use
.. S CNT2=CNT2+1
.. S SKIPPED=$S($G(SKIPPED)]"":SKIPPED_",",1:"")_LIST(DA)
.. Q
. S CNT=CNT+1
. S DELETED=$S($G(DELETED)]"":DELETED_",",1:"")_LIST(DA)
. S DIK="^IBE(350.9,"_DA(1)_","_NODE_","
. D ^DIK
S DIR(0)="EA",Z=1
S DIR("A",Z)=" ",Z=Z+1
I STR="" S DIR("A",Z)="No records selected",Z=Z+1
I STR'="" D
. I $D(LIST) D
. . S Z1=0
. . I CNT D
. . . S DIR("A",Z)="The following "_CNT_" primary ID type"_$S(CNT>1:"s",1:"")_" deleted:",Z=Z+1
. . . S DIR("A",Z)=DELETED,Z=Z+1
. . . Q
. . I CNT2 D
. . . S DIR("A",Z)="The following "_CNT2_" primary ID type"_$S(CNT2>1:"s are",1:" is")_" in use and cannot be deleted:",Z=Z+1
. . . S DIR("A",Z)=SKIPPED,Z=Z+1
. . . S DIR("A",Z)="You must delete the ID from the Insurance Company file first.",Z=Z+1
S DIR("A",Z)=" ",Z=Z+1
S DIR("A")="Press RETURN to continue "
D ^DIR
D UNLOCK(NODE) ; Unlock Site Parameter node
I STR]"" D INIT(WHICH) ; Rebuild list body
Q
;
ENTSEL(NODE,IENS,WHICHF) ; Selects an entry to be added to the specified Site Parameter Node
; Input:
; NODE - Site Parameter node where the data resides
; IENS - not really being passed in
; WHICHF - 1 - Using template IBJP ADMIN CONTRACTOR MED
; 2 - Using template IBJP ADMIN CONTRACTOR COM
; Output: IENS - Array of selected IEN(s), "" if not selected
; Returns: 1 - At least one IEN selected, 0 otherwise
N DA,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,IX,STOP,STOP2,X,XX,Y
N TARGET,ERROR,FDA,FDAIEN,IBSAVEX,SCREEN,IBNODE
K IENS
S IBNODE=$S(WHICHF=1:81,1:82)
S STOP=0
;
F D Q:STOP
. K DIR
. S DIR(0)="355.98,.01O^^S X=$$UP^XLFSTR(X)" ; "O" is for optional
. S DIR("A")="Enter a Primary ID Type"
. D ^DIR
. I $G(DIRUT) S STOP=1 Q
. K DILIST,FDA,TARGET,ERROR,FDAIEN
. S X=$$UP^XLFSTR(X)
. S IBSAVEX=X
. S SCREEN="I '$D(^IBE(350.9,1,IBNODE,""B"",+Y))" ; screen out the ones already there. After all, this is the add action
. D FIND^DIC(355.98,,,"O",X,"*",,SCREEN,,"TARGET","ERROR") ; looks for an exact match 1st. If not, then look for partials.
. ;
. ; There was one match but already in the mulitple. Can't add it if it's already there.
. I +$G(TARGET("DILIST",0))=0,$D(^IBA(355.98,"B",IBSAVEX)) Q
. ;
. ; found one entry in the file that was not in the mutiple already. see if that's it
. I +$G(TARGET("DILIST",0))=1 D Q:$G(STOP) Q:Y
. . W $E($G(TARGET("DILIST",1,1)),$L(IBSAVEX)+1,99) ; only found one so write the rest of it if it was a partial match
. . K DIR
. . S DIR(0)="Y",DIR("B")="YES",DIR("A")="OK" D ^DIR
. . I $G(DIRUT) S STOP=1 Q
. . ; they said it wasn't the one so STOP if the entered value was an exact match to one in the file.
. . ; Don't if it's not; they may want to add later
. . I 'Y S:IBSAVEX=$G(TARGET("DILIST",1,1)) STOP=1 K TARGET Q
. . S IENS(+$G(TARGET("DILIST",2,1)))=""
. ;
. ; found more than one entry, pick one
. I +$G(TARGET("DILIST",0))>1 D Q:$G(STOP) Q:$D(TARGET)
. . F I=1:1:+$G(TARGET("DILIST",0)) W !,I,?3,TARGET("DILIST",1,I)
. . S DIR(0)="NO^1:"_+$G(TARGET("DILIST",0))
. . D ^DIR
. . I $G(DUOUT) S STOP=1 Q ; ^ out
. . I $G(X) S IENS(+$G(TARGET("DILIST",2,X)))="" Q ; actually selected one
. . I X="" S:$D(^IBA(355.98,"B",IBSAVEX)) STOP=1 K TARGET Q ; set STOP if it was already in the file.
. ;
. ; either found no entries or didn't like the the others.
. I '+$G(TARGET("DILIST",0)) D Q ; no matches so add it to 355.98
. . K DIR
. . S DIR(0)="Y",DIR("B")="YES",DIR("A")="OK to Add"_$S($D(TARGET):"",1:" '"_IBSAVEX_"'") D ^DIR
. . I $G(DIRUT) S STOP=1 Q
. . I 'Y Q
. . S FDA("355.98","+1,",.01)=IBSAVEX
. . D UPDATE^DIE("ES","FDA","FDAIEN")
. . S IENS(+FDAIEN(1))=""
. ; I had a list but didn't like any of them. Should I add?
.
;
I '$D(IENS) Q 0 ; No IENS selected
Q 1
;
LOCK(NODE) ;EP
; Attempt to lock the Site Parameter node that is being worked
; Input: NODE - Site Parameter node where the data resides
; Returns: 1 - Successfully locked
; 0 - Not successfully locked and an error message is
; displayed
N DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,TEXT,X,Y
L +^IBE(350.9,1,NODE):1
I '$T D Q 0
. S:NODE=81 TEXT="Medicare Primary ID Types"
. S:NODE=82 TEXT="Commercial Primary ID Types"
. W @IOF,"Someone else is editing the "_TEXT
. W !,"Please Try again later"
. D PAUSE^VALM1
Q 1
;
UNLOCK(NODE) ;EP
; Unlocks the Site Parameter node that is being worked
; Input: NODE - Site Parameter node where the data resides
L -^IBE(350.9,1,NODE)
Q
;
SELEVENT(FULL,PROMPT,DLINE,MULT,WLIST) ; Select Entry(s) to perform an action upon
; Input: FULL - 1 - full screen mode, 0 otherwise
; PROMPT - Prompt to be displayed to the user
; MULT - 1 to allow multiple entry selection
; 0 to only allow single entry selection
; Optional, defaults to 0
; WLIST - Worklist, the user is selecting from
; Set to 'IBTRH5IX' when called from the
; response worklist.
; Optional, defaults to 'IBTRH1IX'
; ^TMP($J,"IBJPS6IX") - Index of displayed lines of the HCSR Worklist
; Only used if WLIST is not 'IBJPS6IX"
; Output: DLINE - Comma delimitted list of Line #(s) of the
; selected entries
; Returns: EIN(s) - Comma delimitted string or IENS for the selected entry(s)
; Error message and "" IENS if multi-selection and not allowed
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,EIEN,EIENS,IX,VALMY,X,Y
S:'$D(WLIST) WLIST="IBJPS6IX"
D:FULL FULL^VALM1
S DLINE=$P($P($G(XQORNOD(0)),"^",4),"=",2) ; User selection with action
S DLINE=$TR(DLINE,"/\; .",",,,,,") ; Check for multi-selection
S EIENS=""
;
I 'MULT,DLINE["," D Q "" ; Invalid multi-selection
. W !,*7,">>>> Only single entry selection is allowed"
. S DLINE=""
. K DIR
. D PAUSE^VALM1
;
; Check the user enter their selection(s)
D EN^VALM2($G(XQORNOD(0)),"O") ; ListMan generic selector
I '$D(VALMY) Q ""
S IX="",DLINE=""
F D Q:IX=""
. S IX=$O(VALMY(IX))
. Q:IX=""
. S DLINE=$S(DLINE="":IX,1:DLINE_","_IX)
. S EIEN=$G(^TMP($J,WLIST,IX))
. S EIENS=$S(EIENS="":EIEN,1:EIENS_","_EIEN)
Q EIENS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJPS6 12940 printed Nov 22, 2024@17:33:45 Page 2
IBJPS6 ;ALB/WCJ - IB Site Parameters, Administrative Contractors ; 27-AUG-2015
+1 ;;2.0;INTEGRATED BILLING;**547**;21-MAR-94;Build 119
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;
+4 ;
+5 QUIT
+6 ;
EN(WHICH) ; -- main entry point for IBJP ALT PRIM PAYER ID TYP
+1 ; Input: WHICH - 1 - Using template IBJP ADMIN CONTRACTOR MED
+2 ; 2 - Using template IBJP ADMIN CONTRACTOR COM
+3 NEW TEMPLATE
+4 SET TEMPLATE=$SELECT(WHICH=1:"IBJP ADMIN CONTRACTOR MED",1:"IBJP ADMIN CONTRACTOR COM")
+5 DO EN^VALM(TEMPLATE)
+6 QUIT
+7 ;
HDR(WHICH) ; -- header code
+1 ; Input: WHICH - 1 - Using template IBJP ADMIN CONTRACTOR MED
+2 ; 2 - Using template IBJP ADMIN CONTRACTOR COM
+3 ;
+4 if WHICH=1
SET VALMHDR(1)="Medicare"
+5 if WHICH=2
SET VALMHDR(1)="Commercial"
+6 QUIT
+7 ;
INIT(WHICH) ; Initialize variables and list array
+1 ; Input: WHICH - 1 - Using template IBJP ADMIN CONTRACTOR MED
+2 ; 2 - Using template IBJP ADMIN CONTRACTOR COM
+3 ; Output: ^TMP("IBJPS6",$J) - Body lines to display for specified template
+4 KILL ^TMP("IBJPS6",$JOB),^TMP($JOB,"IBJPS6IX")
+5 DO BLD(WHICH)
+6 QUIT
+7 ;
BLD(WHICH) ; Build screen array, no variables required for input
+1 ; Input: WHICH - 1 - Using template IBJP ADMIN CONTRACTOR MED
+2 ; 2 - Using template IBJP ADMIN CONTRACTOR COM
+3 ; Output: ^TMP("IBJPS6",$J) - Body lines to display for specified template
+4 ;
+5 NEW CNT,ENTRIES,LINE,NAME,NAMEIEN,NODE,NODE0,Z
+6 SET VALMCNT=0
+7 SET NODE=$SELECT(WHICH=1:81,1:82)
+8 SET (Z,CNT)=0
+9 FOR
Begin DoDot:1
+10 SET Z=$ORDER(^IBE(350.9,1,NODE,Z))
+11 if +Z=0
QUIT
+12 SET NODE0=$GET(^IBE(350.9,1,NODE,Z,0))
SET NAMEIEN=+$PIECE(NODE0,U,1)
+13 IF NAMEIEN>0
Begin DoDot:2
+14 SET CNT=CNT+1
SET NAME=$$EXTERNAL^DILFD(350.9_NODE,.01,"",NAMEIEN)
+15 IF NAME'=""
Begin DoDot:3
+16 SET ENTRIES(NAME,CNT)=NAMEIEN
SET ENTRIES(NAME,CNT,"IEN")=Z
End DoDot:3
End DoDot:2
End DoDot:1
if +Z=0
QUIT
+17 IF '$DATA(ENTRIES)
Begin DoDot:1
+18 SET LINE=$$SETL("","","** No entries found **",29,22)
+19 SET ^TMP("IBJPS6",$JOB,1,0)=LINE
End DoDot:1
QUIT
+20 ;
+21 SET NAME=""
+22 FOR
Begin DoDot:1
+23 SET NAME=$ORDER(ENTRIES(NAME))
if NAME=""
QUIT
+24 SET Z=0
FOR
Begin DoDot:2
+25 SET Z=$ORDER(ENTRIES(NAME,Z))
if Z=""
QUIT
+26 SET VALMCNT=VALMCNT+1
+27 SET LINE=$$BLDLN(VALMCNT,NAME,ENTRIES(NAME,Z))
+28 DO SET^VALM10(VALMCNT,LINE,VALMCNT)
+29 SET ^TMP($JOB,"IBJPS6IX",VALMCNT)=ENTRIES(NAME,Z,"IEN")
+30 QUIT
End DoDot:2
if Z=""
QUIT
+31 QUIT
End DoDot:1
if NAME=""
QUIT
+32 QUIT
+33 ;
BLDLN(CTR,NAME,IEN) ; Builds a line to display and insurance
+1 ; Input: CTR - Current Line Counter
+2 ; NAME - Insurance Company Name
+3 ; IEN - IEN of the insurance to be displayed
+4 ; Output: LINE - Formatted for settng into the list display
+5 NEW LINE,XX
+6 ; Entry #
SET LINE=$$SETSTR^VALM1(CTR,"",1,4)
+7 ; Administrative Contractor Type
SET LINE=$$SETSTR^VALM1(NAME,LINE,6,66)
+8 QUIT LINE
+9 ;
SETL(LINE,DATA,LABEL,COL,LNG) ; Creates a line of data to be set into the body
+1 ; of the worklist
+2 ; Input: LINE - Current line being created
+3 ; DATA - Information to be added to the end of the current line
+4 ; LABEL - Label to describe the information being added
+5 ; COL - Column position in line to add information add
+6 ; LNG - Maximum length of data information to include on the line
+7 ; Returns: Line updated with added information
+8 SET LINE=LINE_$JUSTIFY("",(COL-$LENGTH(LABEL)-$LENGTH(LINE)))_LABEL_$EXTRACT(DATA,1,LNG)
+9 QUIT LINE
+10 ;
HELP(WHICH) ; -- help code
+1 ; Input: WHICH - 1 - Using template IBJP ADMIN CONTRACTOR MED
+2 ; 2 - Using template IBJP ADMIN CONTRACTOR COM
+3 SET X="?"
DO DISP^XQORM1
WRITE !!
+4 QUIT
+5 ;
EXIT(WHICH) ; Exit code
+1 ; Input: WHICH - 1 - Using template IBJP ADMIN CONTRACTOR MED
+2 ; 2 - Using template IBJP ADMIN CONTRACTOR COM
+3 KILL ^TMP("IBJPS6",$JOB),^TMP($JOB,"IBJPS6IX")
+4 DO CLEAR^VALM1
+5 QUIT
+6 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
ADD(WHICH) ; Listman Protocol Action to add an entry to the specified Site Parameter node
+1 ; Input: WHICH - 1 - Using template IBJP ADMIN CONTRACTOR MED
+2 ; 2 - Using template IBJP ADMIN CONTRACTOR COM
+3 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,FDA,IEN,IENS,INSM,INSMC
+4 NEW NODE,NAME,NAMEU,NODE0,X,XX,Y,Z,Z1
+5 SET NODE=$SELECT(WHICH=1:81,1:82)
+6 ; Refresh screen on return
SET VALMBCK="R"
+7 ; Couldn't lock for adding
if '$$LOCK(NODE)
QUIT
+8 DO FULL^VALM1
+9 ;
+10 ; Select entry(s) to be added
IF '$$ENTSEL(NODE,.IENS,WHICH)
Begin DoDot:1
+11 SET VALMSG="No Primary ID Types selected"
+12 DO UNLOCK(NODE)
End DoDot:1
QUIT
+13 ;
+14 ; Add the selected entries into the list
+15 SET IEN=""
+16 FOR
Begin DoDot:1
+17 SET IEN=$ORDER(IENS(IEN))
+18 if IEN=""
QUIT
+19 ; don't add it, it's already there.
if $$FIND1^DIC("350.9"_NODE,",1,","QX",IEN)
QUIT
+20 SET FDA("350.9"_NODE,"+1,1,",.01)=IEN
+21 DO UPDATE^DIE("","FDA")
End DoDot:1
if IEN=""
QUIT
+22 ; Unlock the Node
DO UNLOCK(NODE)
+23 ;
+24 ; Rebuild list body
DO INIT(WHICH)
+25 SET VALMSG="Added Primary ID Types"
+26 QUIT
+27 ;
DEL(WHICH) ; Listman Protocol Action to delete an entry from the specified Site Parameter node
+1 ; Input: WHICH - 1 - Using template IBJP ADMIN CONTRACTOR MED
+2 ; 2 - Using template IBJP ADMIN CONTRACTOR COM
+3 ;
+4 NEW CNT,CNT2,DA,DIK,DIR,DIROUT,DIRUT,DTOUT,DUOUT,LIST,NAME
+5 NEW NODE,NODE0,SELSTR,STR,X,XX,Y,Z,Z1,OTHER,SKIPPED,DELETED
+6 SET NODE=$SELECT(WHICH=1:81,1:82)
+7 SET OTHER=$SELECT(NODE=82:81,1:82)
+8 ; Refresh screen on return
SET VALMBCK="R"
+9 ; Couldn't lock for deletion
if '$$LOCK(NODE)
QUIT
+10 ; Display warning message
DO FULL^VALM1
+11 SET STR=$$SELEVENT(0,"",.SELSTR,1,"IBJPS6IX")
+12 ;
+13 ; Select entry(s) to be added
IF STR=""
Begin DoDot:1
+14 SET VALMSG="No Pimary ID Types selected"
+15 ; resetting this variable which disappeared to refresh screen
SET VALMBCK="R"
+16 DO UNLOCK(NODE)
End DoDot:1
QUIT
+17 ;
+18 IF STR'=""
Begin DoDot:1
+19 FOR Z=1:1:$LENGTH(STR,",")
Begin DoDot:2
+20 SET Z1=$PIECE(STR,",",Z)
SET NODE0=$GET(^IBE(350.9,1,NODE,Z1,0))
+21 SET NAME=$$EXTERNAL^DILFD(350.9_NODE,.01,"",+$PIECE(NODE0,"^",1))
+22 SET LIST(Z1)=NAME
+23 SET LIST(Z1,"I")=+NODE0
End DoDot:2
End DoDot:1
+24 ;
+25 ; Delete the selected entries from the list
+26 SET DA(1)=1
SET (CNT,CNT2,DA)=0
+27 SET SKIPPED=""
+28 FOR
SET DA=$ORDER(LIST(DA))
if 'DA
QUIT
Begin DoDot:1
+29 ; don't let them delete ones in use
IF $DATA(^DIC(36,"AB",LIST(DA,"I")))!($DATA(^DIC(36,"AD",LIST(DA,"I"))))
IF '$DATA(^IBE(350.9,1,OTHER,"B",LIST(DA,"I")))
Begin DoDot:2
+30 SET CNT2=CNT2+1
+31 SET SKIPPED=$SELECT($GET(SKIPPED)]"":SKIPPED_",",1:"")_LIST(DA)
+32 QUIT
End DoDot:2
QUIT
+33 SET CNT=CNT+1
+34 SET DELETED=$SELECT($GET(DELETED)]"":DELETED_",",1:"")_LIST(DA)
+35 SET DIK="^IBE(350.9,"_DA(1)_","_NODE_","
+36 DO ^DIK
End DoDot:1
+37 SET DIR(0)="EA"
SET Z=1
+38 SET DIR("A",Z)=" "
SET Z=Z+1
+39 IF STR=""
SET DIR("A",Z)="No records selected"
SET Z=Z+1
+40 IF STR'=""
Begin DoDot:1
+41 IF $DATA(LIST)
Begin DoDot:2
+42 SET Z1=0
+43 IF CNT
Begin DoDot:3
+44 SET DIR("A",Z)="The following "_CNT_" primary ID type"_$SELECT(CNT>1:"s",1:"")_" deleted:"
SET Z=Z+1
+45 SET DIR("A",Z)=DELETED
SET Z=Z+1
+46 QUIT
End DoDot:3
+47 IF CNT2
Begin DoDot:3
+48 SET DIR("A",Z)="The following "_CNT2_" primary ID type"_$SELECT(CNT2>1:"s are",1:" is")_" in use and cannot be deleted:"
SET Z=Z+1
+49 SET DIR("A",Z)=SKIPPED
SET Z=Z+1
+50 SET DIR("A",Z)="You must delete the ID from the Insurance Company file first."
SET Z=Z+1
End DoDot:3
End DoDot:2
End DoDot:1
+51 SET DIR("A",Z)=" "
SET Z=Z+1
+52 SET DIR("A")="Press RETURN to continue "
+53 DO ^DIR
+54 ; Unlock Site Parameter node
DO UNLOCK(NODE)
+55 ; Rebuild list body
IF STR]""
DO INIT(WHICH)
+56 QUIT
+57 ;
ENTSEL(NODE,IENS,WHICHF) ; Selects an entry to be added to the specified Site Parameter Node
+1 ; Input:
+2 ; NODE - Site Parameter node where the data resides
+3 ; IENS - not really being passed in
+4 ; WHICHF - 1 - Using template IBJP ADMIN CONTRACTOR MED
+5 ; 2 - Using template IBJP ADMIN CONTRACTOR COM
+6 ; Output: IENS - Array of selected IEN(s), "" if not selected
+7 ; Returns: 1 - At least one IEN selected, 0 otherwise
+8 NEW DA,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,IX,STOP,STOP2,X,XX,Y
+9 NEW TARGET,ERROR,FDA,FDAIEN,IBSAVEX,SCREEN,IBNODE
+10 KILL IENS
+11 SET IBNODE=$SELECT(WHICHF=1:81,1:82)
+12 SET STOP=0
+13 ;
+14 FOR
Begin DoDot:1
+15 KILL DIR
+16 ; "O" is for optional
SET DIR(0)="355.98,.01O^^S X=$$UP^XLFSTR(X)"
+17 SET DIR("A")="Enter a Primary ID Type"
+18 DO ^DIR
+19 IF $GET(DIRUT)
SET STOP=1
QUIT
+20 KILL DILIST,FDA,TARGET,ERROR,FDAIEN
+21 SET X=$$UP^XLFSTR(X)
+22 SET IBSAVEX=X
+23 ; screen out the ones already there. After all, this is the add action
SET SCREEN="I '$D(^IBE(350.9,1,IBNODE,""B"",+Y))"
+24 ; looks for an exact match 1st. If not, then look for partials.
DO FIND^DIC(355.98,,,"O",X,"*",,SCREEN,,"TARGET","ERROR")
+25 ;
+26 ; There was one match but already in the mulitple. Can't add it if it's already there.
+27 IF +$GET(TARGET("DILIST",0))=0
IF $DATA(^IBA(355.98,"B",IBSAVEX))
QUIT
+28 ;
+29 ; found one entry in the file that was not in the mutiple already. see if that's it
+30 IF +$GET(TARGET("DILIST",0))=1
Begin DoDot:2
+31 ; only found one so write the rest of it if it was a partial match
WRITE $EXTRACT($GET(TARGET("DILIST",1,1)),$LENGTH(IBSAVEX)+1,99)
+32 KILL DIR
+33 SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="OK"
DO ^DIR
+34 IF $GET(DIRUT)
SET STOP=1
QUIT
+35 ; they said it wasn't the one so STOP if the entered value was an exact match to one in the file.
+36 ; Don't if it's not; they may want to add later
+37 IF 'Y
if IBSAVEX=$GET(TARGET("DILIST",1,1))
SET STOP=1
KILL TARGET
QUIT
+38 SET IENS(+$GET(TARGET("DILIST",2,1)))=""
End DoDot:2
if $GET(STOP)
QUIT
if Y
QUIT
+39 ;
+40 ; found more than one entry, pick one
+41 IF +$GET(TARGET("DILIST",0))>1
Begin DoDot:2
+42 FOR I=1:1:+$GET(TARGET("DILIST",0))
WRITE !,I,?3,TARGET("DILIST",1,I)
+43 SET DIR(0)="NO^1:"_+$GET(TARGET("DILIST",0))
+44 DO ^DIR
+45 ; ^ out
IF $GET(DUOUT)
SET STOP=1
QUIT
+46 ; actually selected one
IF $GET(X)
SET IENS(+$GET(TARGET("DILIST",2,X)))=""
QUIT
+47 ; set STOP if it was already in the file.
IF X=""
if $DATA(^IBA(355.98,"B",IBSAVEX))
SET STOP=1
KILL TARGET
QUIT
End DoDot:2
if $GET(STOP)
QUIT
if $DATA(TARGET)
QUIT
+48 ;
+49 ; either found no entries or didn't like the the others.
+50 ; no matches so add it to 355.98
IF '+$GET(TARGET("DILIST",0))
Begin DoDot:2
+51 KILL DIR
+52 SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="OK to Add"_$SELECT($DATA(TARGET):"",1:" '"_IBSAVEX_"'")
DO ^DIR
+53 IF $GET(DIRUT)
SET STOP=1
QUIT
+54 IF 'Y
QUIT
+55 SET FDA("355.98","+1,",.01)=IBSAVEX
+56 DO UPDATE^DIE("ES","FDA","FDAIEN")
+57 SET IENS(+FDAIEN(1))=""
End DoDot:2
QUIT
+58 ; I had a list but didn't like any of them. Should I add?
+59 End DoDot:1
if STOP
QUIT
+60 ;
+61 ; No IENS selected
IF '$DATA(IENS)
QUIT 0
+62 QUIT 1
+63 ;
LOCK(NODE) ;EP
+1 ; Attempt to lock the Site Parameter node that is being worked
+2 ; Input: NODE - Site Parameter node where the data resides
+3 ; Returns: 1 - Successfully locked
+4 ; 0 - Not successfully locked and an error message is
+5 ; displayed
+6 NEW DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,TEXT,X,Y
+7 LOCK +^IBE(350.9,1,NODE):1
+8 IF '$TEST
Begin DoDot:1
+9 if NODE=81
SET TEXT="Medicare Primary ID Types"
+10 if NODE=82
SET TEXT="Commercial Primary ID Types"
+11 WRITE @IOF,"Someone else is editing the "_TEXT
+12 WRITE !,"Please Try again later"
+13 DO PAUSE^VALM1
End DoDot:1
QUIT 0
+14 QUIT 1
+15 ;
UNLOCK(NODE) ;EP
+1 ; Unlocks the Site Parameter node that is being worked
+2 ; Input: NODE - Site Parameter node where the data resides
+3 LOCK -^IBE(350.9,1,NODE)
+4 QUIT
+5 ;
SELEVENT(FULL,PROMPT,DLINE,MULT,WLIST) ; Select Entry(s) to perform an action upon
+1 ; Input: FULL - 1 - full screen mode, 0 otherwise
+2 ; PROMPT - Prompt to be displayed to the user
+3 ; MULT - 1 to allow multiple entry selection
+4 ; 0 to only allow single entry selection
+5 ; Optional, defaults to 0
+6 ; WLIST - Worklist, the user is selecting from
+7 ; Set to 'IBTRH5IX' when called from the
+8 ; response worklist.
+9 ; Optional, defaults to 'IBTRH1IX'
+10 ; ^TMP($J,"IBJPS6IX") - Index of displayed lines of the HCSR Worklist
+11 ; Only used if WLIST is not 'IBJPS6IX"
+12 ; Output: DLINE - Comma delimitted list of Line #(s) of the
+13 ; selected entries
+14 ; Returns: EIN(s) - Comma delimitted string or IENS for the selected entry(s)
+15 ; Error message and "" IENS if multi-selection and not allowed
+16 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,EIEN,EIENS,IX,VALMY,X,Y
+17 if '$DATA(WLIST)
SET WLIST="IBJPS6IX"
+18 if FULL
DO FULL^VALM1
+19 ; User selection with action
SET DLINE=$PIECE($PIECE($GET(XQORNOD(0)),"^",4),"=",2)
+20 ; Check for multi-selection
SET DLINE=$TRANSLATE(DLINE,"/\; .",",,,,,")
+21 SET EIENS=""
+22 ;
+23 ; Invalid multi-selection
IF 'MULT
IF DLINE[","
Begin DoDot:1
+24 WRITE !,*7,">>>> Only single entry selection is allowed"
+25 SET DLINE=""
+26 KILL DIR
+27 DO PAUSE^VALM1
End DoDot:1
QUIT ""
+28 ;
+29 ; Check the user enter their selection(s)
+30 ; ListMan generic selector
DO EN^VALM2($GET(XQORNOD(0)),"O")
+31 IF '$DATA(VALMY)
QUIT ""
+32 SET IX=""
SET DLINE=""
+33 FOR
Begin DoDot:1
+34 SET IX=$ORDER(VALMY(IX))
+35 if IX=""
QUIT
+36 SET DLINE=$SELECT(DLINE="":IX,1:DLINE_","_IX)
+37 SET EIEN=$GET(^TMP($JOB,WLIST,IX))
+38 SET EIENS=$SELECT(EIENS="":EIEN,1:EIENS_","_EIEN)
End DoDot:1
if IX=""
QUIT
+39 QUIT EIENS
