IBCNBLE1 ;DAOU/ESG - Ins Buffer, Expand Entry, con't ;25-JUN-2002
;;2.0;INTEGRATED BILLING;**184,271,416,435,467,516,601,668,737**;21-MAR-94;Build 19
;;Per VA Directive 6402, this routine should not be modified.
;
; Can't be called from the top
Q
;
BLD ; Continuation of Expand Entry list build procedure
; --- Called by IBCNBLE
;
NEW ERR,MSG,IBL,IBY,IBLINE,IBER,IBLN,EDITED,ORIGSYME,ORIGSYMI,EEUPDATE
NEW ORIGSYMS
;
; save the external and internal IIV status values
S ORIGSYMS=$$SYMBOL^IBCNBLL(IBBUFDA)
S ORIGSYME=$$GET1^DIQ(355.33,IBBUFDA,.12,"E")
S ORIGSYMI=$P(IB0,U,12)
;
; Determine if Expand Entry is allowed to update the IIV Status
S EEUPDATE=1 ; default Expand Entry update flag to true
I ORIGSYMI,'$P($G(^IBE(365.15,ORIGSYMI,0)),U,3) S EEUPDATE=0
;
; Do not update the IIV status if manually verified
;I ORIGSYMS="*" S EEUPDATE=0 ;IB*737/DTG stop '*' verified
;
; Don't let Expand Entry update the eIV status for ePharmacy buffer entries
; esg - 10/12/10 - IB*2*435
I +$P($G(^IBA(355.33,IBBUFDA,0)),U,17) S EEUPDATE=0
;
; If the current IIV Status allows updates by Expand Entry, then
; invoke the function that trys to find a valid payer
I EEUPDATE D
. S ERR=$$INSERROR^IBCNEUT3("B",IBBUFDA,1,.MSG)
. ; If no errors, then remove the IIV Status
. I 'ERR S ERR=$$SIDERR(IBBUFDA,$P(ERR,U,2))
. I 'ERR S ERR=$$PIDERR(IBBUFDA)
. I 'ERR D CLEAR^IBCNEUT4(IBBUFDA,.EDITED)
. ; If errors found, then update with the new IIV Status
. I ERR D BUFF^IBCNEUT2(IBBUFDA,$P(ERR,U,1)) S EDITED=1
. ; refresh the IB0 variable for the possible symbol change
. S $P(IB0,U,12)=$P($G(^IBA(355.33,IBBUFDA,0)),U,12)
. Q
;
; Possibly display information if the OVERRIDE FRESHNESS FLAG is on
I $P(IB0,U,13) D
. S IBL="User Requested Inquiry?: ",IBY="YES"
. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,18,3)
. D SET^IBCNBLE(IBLINE) S IBLINE=""
. Q
;
; Display the Current Status line
S IBL="Current eIV Status: "
S IBY=$$GET1^DIQ(355.33,IBBUFDA,.12,"E")
;I IBY="",$$SYMBOL^IBCNBLL(IBBUFDA)'="*" S IBY="No problems identified, Awaiting electronic processing"
I IBY="" S IBY="No problems identified, Awaiting electronic processing" ;IB*737/DTG stop '*' verified
I $$SYMBOL^IBCNBLL(IBBUFDA)="*" S IBY="Manually verified, No eIV activity at this time"
;
; esg - 10/12/10 - check for epharmacy entries
I +$P($G(^IBA(355.33,IBBUFDA,0)),U,17) S IBY="N/A for e-Pharmacy buffer entries"
;
S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,18,80)
D SET^IBCNBLE(IBLINE) S IBLINE=""
;
; Display any text returned by the payer function
F IBER=1:1:$G(MSG) D SET^IBCNBLE(" ") F IBLN=1:1:$P($G(MSG(IBER)),U,2) D SET^IBCNBLE(" "_$G(MSG(IBER,IBLN)))
;
; Display the current IIV Status generic description
D SYMTXT($P(IB0,U,12),1)
D SYMTXT($P(IB0,U,12),2)
;
; If the IIV Status ien changed from what it once was, then display the
; Prior Status line
I ORIGSYMI'=$P(IB0,U,12) D
. I $P(IB0,U,12) D SET^IBCNBLE(" ")
. S IBL="Prior Status: "
. S IBY=ORIGSYME
. ;I IBY="",ORIGSYMS'="*" S IBY="No problems identified, Awaiting electronic processing"
. ;I ORIGSYMS="*" S IBY="Manually verified, No eIV activity at this time"
. I IBY="" S IBY="No problems identified, Awaiting electronic processing" ;IB*737/DTG stop '*' verified
. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,18,80)
. D SET^IBCNBLE(IBLINE) S IBLINE=""
. D SYMTXT(ORIGSYMI,1)
. Q
;
; Display any existing EC errors
D ECERR
; IB*2*601/DM display possible notes
D ECNOTE(IBBUFDA)
;D SET^IBCNBLE(" ")
;
; If the IIV Status was modified then refresh the visual display
I $G(EDITED) D UPDLN^IBCNBLL(IBBUFDA,"EDITED")
BLDX ;
Q
;
SYMTXT(IEN,TYPE) ; Display the text from the IIV symbol file for this entry
; TYPE=1 - Display Description from IIV Status Table file
; TYPE=2 - Display Corrective Action from IIV Status Table file
NEW IBJ
I '$G(IEN) G SYMX
I '$P($G(^IBE(365.15,IEN,TYPE,0)),U,4) G SYMX
D SET^IBCNBLE(" ")
S IBJ=0
F S IBJ=$O(^IBE(365.15,IEN,TYPE,IBJ)) Q:'IBJ D SET^IBCNBLE(" "_$G(^IBE(365.15,IEN,TYPE,IBJ,0)))
SYMX ;
Q
;
ECERR ; Display the Eligibility Communicator Error data from the
; response file if it exists
;
NEW RESP,RESPDATA,ERRTXT,IBY,IBLINE,ERRDATA,FUTDT,TQIEN,IBERR,IBCT
S RESP=$O(^IBCN(365,"AF",IBBUFDA,""),-1)
I 'RESP G ECERRX
S RESPDATA=$G(^IBCN(365,RESP,1))
S ERRTXT=$P($G(^IBCN(365,RESP,4)),U,1)
S TQIEN=+$P($G(^IBCN(365,RESP,0)),U,5) ; Trans Queue file ien
S FUTDT=$P($G(^IBCN(365.1,TQIEN,0)),U,9) ; Future date to transmit
I '$P(RESPDATA,U,14),'$P(RESPDATA,U,15),ERRTXT="",'FUTDT G ECERRX
;
; At this point, we know there's something to get displayed
;
; Display section header
D SET^IBCNBLE(" ")
S IBY=$J("",19)_"Eligibility Communicator Error Information"
D SET^IBCNBLE(IBY,"B") S IBLINE=""
;
; Display Error Condition data - field# 1.14
I $P(RESPDATA,U,14) D
. S ERRDATA=$G(^IBE(365.017,$P(RESPDATA,U,14),0))
. K IBERR
. S IBERR(1)=$P(ERRDATA,U,2)_" (Error Condition '"_$P(ERRDATA,U,1)_"')"
. D TXT^IBCNEUT7("IBERR")
. F IBCT=1:1:$O(IBERR(""),-1) D SET^IBCNBLE(IBERR(IBCT))
. Q
;
; Display Error Action data - field# 1.15
I $P(RESPDATA,U,15) D
. S ERRDATA=$G(^IBE(365.018,$P(RESPDATA,U,15),0))
. K IBERR
. S IBERR(1)=$P(ERRDATA,U,2)_" (Error Action '"_$P(ERRDATA,U,1)_"')"
. D TXT^IBCNEUT7("IBERR")
. F IBCT=1:1:$O(IBERR(""),-1) D SET^IBCNBLE(IBERR(IBCT))
. Q
;
; Display Error Text data - field# 4.01
I ERRTXT'="" D SET^IBCNBLE(ERRTXT)
;
; Display Date of Future Transmission - field# .09 in file 365.1
I FUTDT D
. S FUTDT=$$FMTE^XLFDT(FUTDT,"5Z")
. D SET^IBCNBLE(" ")
. S IBLINE=" Date of Future Transmission: "_FUTDT
. D SET^IBCNBLE(IBLINE) S IBLINE=""
. Q
ECERRX ;
Q
;
ECNOTE(IBBUFDA) ; IB*2*601/DM
N IBRIEN,IBD1,IBMSG,IB1ST,IBTXT,IBCT
I '$$MBICHK^IBCNEUT7(IBBUFDA) G ECNOTEX
S IBRIEN=$O(^IBCN(365,"AF",IBBUFDA,""),-1)
I 'IBRIEN G ECNOTEX
S IB1ST=1
S IBD1=0
F S IBD1=$O(^IBCN(365,IBRIEN,6,IBD1)) Q:'IBD1 D
.S IBMSG=0
.F S IBMSG=$O(^IBCN(365,IBRIEN,6,IBD1,1,IBMSG)) Q:'IBMSG D
..S IBTXT(1)=^IBCN(365,IBRIEN,6,IBD1,1,IBMSG,0)
..I IB1ST D
...S IB1ST=0
...; Display section header
...D SET^IBCNBLE(" ")
...S IBY=$J("",19)_"Eligibility Communicator Notes"
...D SET^IBCNBLE(IBY,"B") S IBLINE=""
..; Display Notes
..D TXT^IBCNEUT7("IBTXT")
..F IBCT=1:1:$O(IBTXT(""),-1) D SET^IBCNBLE(IBTXT(IBCT))
..Q
;
ECNOTEX ;
Q
;
SIDERR(BUF,PIEN) ;
; dw/IB*668 updated utility as the logic was using a field that was made
; obsolete many years ago. It may no longer try to use SSN for the subscriber ID
;
; If Subscriber ID is required and SSN cannot be substituted
; and buffer does not have a sub id -> return error
; BUF = buffer IEN
; PIEN = payer IEN
;
N ERR,SID,APPIEN,SIDREQ
S ERR=""
;S SID=$P($G(^IBA(355.33,BUF,60)),U,4) ; Patch 516 - baa
S SID=$$GET1^DIQ(355.33,BUF,90.03) ; Patch 516 - baa
I SID]"" G SIDX ; Subscriber id is populated, further checking is moot
;IB*668/TAZ - Changed Payer Application from IIV to EIV
S APPIEN=$$PYRAPP^IBCNEUT5("EIV",PIEN)
;S SIDSTR=$G(^IBE(365.12,PIEN,1,APPIEN,0)) ;dw/668 field was moved
;S SIDREQ=$P(SIDSTR,U,8) I 'SIDREQ G SIDX ; if sub id is not req'd - ok
;S SIDSSN=$P(SIDSTR,U,9) I 'SIDSSN S ERR=18 ; if ssn cannot be used -> B15 status (IEN = 18)
S SIDREQ=$$GET1^DIQ(365.121,APPIEN_","_PIEN_",",4.02,"I")
I 'SIDREQ G SIDX ; if sub id is not req'd - ok
S ERR=18 ; missing Subscriber ID and it is required -> B15 status (IEN = 18)
SIDX Q ERR
;
PIDERR(BUF) ;
; If patient is a dependent and patient id is missing return error
; BUF - buffer ien
;
N ERR,PREL
S ERR=""
S PREL=$P($G(^IBA(355.33,BUF,60)),U,14)
I PREL'=18,PREL'="",$P($G(^IBA(355.33,BUF,62)),U)="" S ERR=23
Q ERR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNBLE1 7880 printed Oct 16, 2024@18:14:44 Page 2
IBCNBLE1 ;DAOU/ESG - Ins Buffer, Expand Entry, con't ;25-JUN-2002
+1 ;;2.0;INTEGRATED BILLING;**184,271,416,435,467,516,601,668,737**;21-MAR-94;Build 19
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Can't be called from the top
+5 QUIT
+6 ;
BLD ; Continuation of Expand Entry list build procedure
+1 ; --- Called by IBCNBLE
+2 ;
+3 NEW ERR,MSG,IBL,IBY,IBLINE,IBER,IBLN,EDITED,ORIGSYME,ORIGSYMI,EEUPDATE
+4 NEW ORIGSYMS
+5 ;
+6 ; save the external and internal IIV status values
+7 SET ORIGSYMS=$$SYMBOL^IBCNBLL(IBBUFDA)
+8 SET ORIGSYME=$$GET1^DIQ(355.33,IBBUFDA,.12,"E")
+9 SET ORIGSYMI=$PIECE(IB0,U,12)
+10 ;
+11 ; Determine if Expand Entry is allowed to update the IIV Status
+12 ; default Expand Entry update flag to true
SET EEUPDATE=1
+13 IF ORIGSYMI
IF '$PIECE($GET(^IBE(365.15,ORIGSYMI,0)),U,3)
SET EEUPDATE=0
+14 ;
+15 ; Do not update the IIV status if manually verified
+16 ;I ORIGSYMS="*" S EEUPDATE=0 ;IB*737/DTG stop '*' verified
+17 ;
+18 ; Don't let Expand Entry update the eIV status for ePharmacy buffer entries
+19 ; esg - 10/12/10 - IB*2*435
+20 IF +$PIECE($GET(^IBA(355.33,IBBUFDA,0)),U,17)
SET EEUPDATE=0
+21 ;
+22 ; If the current IIV Status allows updates by Expand Entry, then
+23 ; invoke the function that trys to find a valid payer
+24 IF EEUPDATE
Begin DoDot:1
+25 SET ERR=$$INSERROR^IBCNEUT3("B",IBBUFDA,1,.MSG)
+26 ; If no errors, then remove the IIV Status
+27 IF 'ERR
SET ERR=$$SIDERR(IBBUFDA,$PIECE(ERR,U,2))
+28 IF 'ERR
SET ERR=$$PIDERR(IBBUFDA)
+29 IF 'ERR
DO CLEAR^IBCNEUT4(IBBUFDA,.EDITED)
+30 ; If errors found, then update with the new IIV Status
+31 IF ERR
DO BUFF^IBCNEUT2(IBBUFDA,$PIECE(ERR,U,1))
SET EDITED=1
+32 ; refresh the IB0 variable for the possible symbol change
+33 SET $PIECE(IB0,U,12)=$PIECE($GET(^IBA(355.33,IBBUFDA,0)),U,12)
+34 QUIT
End DoDot:1
+35 ;
+36 ; Possibly display information if the OVERRIDE FRESHNESS FLAG is on
+37 IF $PIECE(IB0,U,13)
Begin DoDot:1
+38 SET IBL="User Requested Inquiry?: "
SET IBY="YES"
+39 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,18,3)
+40 DO SET^IBCNBLE(IBLINE)
SET IBLINE=""
+41 QUIT
End DoDot:1
+42 ;
+43 ; Display the Current Status line
+44 SET IBL="Current eIV Status: "
+45 SET IBY=$$GET1^DIQ(355.33,IBBUFDA,.12,"E")
+46 ;I IBY="",$$SYMBOL^IBCNBLL(IBBUFDA)'="*" S IBY="No problems identified, Awaiting electronic processing"
+47 ;IB*737/DTG stop '*' verified
IF IBY=""
SET IBY="No problems identified, Awaiting electronic processing"
+48 IF $$SYMBOL^IBCNBLL(IBBUFDA)="*"
SET IBY="Manually verified, No eIV activity at this time"
+49 ;
+50 ; esg - 10/12/10 - check for epharmacy entries
+51 IF +$PIECE($GET(^IBA(355.33,IBBUFDA,0)),U,17)
SET IBY="N/A for e-Pharmacy buffer entries"
+52 ;
+53 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,18,80)
+54 DO SET^IBCNBLE(IBLINE)
SET IBLINE=""
+55 ;
+56 ; Display any text returned by the payer function
+57 FOR IBER=1:1:$GET(MSG)
DO SET^IBCNBLE(" ")
FOR IBLN=1:1:$PIECE($GET(MSG(IBER)),U,2)
DO SET^IBCNBLE(" "_$GET(MSG(IBER,IBLN)))
+58 ;
+59 ; Display the current IIV Status generic description
+60 DO SYMTXT($PIECE(IB0,U,12),1)
+61 DO SYMTXT($PIECE(IB0,U,12),2)
+62 ;
+63 ; If the IIV Status ien changed from what it once was, then display the
+64 ; Prior Status line
+65 IF ORIGSYMI'=$PIECE(IB0,U,12)
Begin DoDot:1
+66 IF $PIECE(IB0,U,12)
DO SET^IBCNBLE(" ")
+67 SET IBL="Prior Status: "
+68 SET IBY=ORIGSYME
+69 ;I IBY="",ORIGSYMS'="*" S IBY="No problems identified, Awaiting electronic processing"
+70 ;I ORIGSYMS="*" S IBY="Manually verified, No eIV activity at this time"
+71 ;IB*737/DTG stop '*' verified
IF IBY=""
SET IBY="No problems identified, Awaiting electronic processing"
+72 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,18,80)
+73 DO SET^IBCNBLE(IBLINE)
SET IBLINE=""
+74 DO SYMTXT(ORIGSYMI,1)
+75 QUIT
End DoDot:1
+76 ;
+77 ; Display any existing EC errors
+78 DO ECERR
+79 ; IB*2*601/DM display possible notes
+80 DO ECNOTE(IBBUFDA)
+81 ;D SET^IBCNBLE(" ")
+82 ;
+83 ; If the IIV Status was modified then refresh the visual display
+84 IF $GET(EDITED)
DO UPDLN^IBCNBLL(IBBUFDA,"EDITED")
BLDX ;
+1 QUIT
+2 ;
SYMTXT(IEN,TYPE) ; Display the text from the IIV symbol file for this entry
+1 ; TYPE=1 - Display Description from IIV Status Table file
+2 ; TYPE=2 - Display Corrective Action from IIV Status Table file
+3 NEW IBJ
+4 IF '$GET(IEN)
GOTO SYMX
+5 IF '$PIECE($GET(^IBE(365.15,IEN,TYPE,0)),U,4)
GOTO SYMX
+6 DO SET^IBCNBLE(" ")
+7 SET IBJ=0
+8 FOR
SET IBJ=$ORDER(^IBE(365.15,IEN,TYPE,IBJ))
if 'IBJ
QUIT
DO SET^IBCNBLE(" "_$GET(^IBE(365.15,IEN,TYPE,IBJ,0)))
SYMX ;
+1 QUIT
+2 ;
ECERR ; Display the Eligibility Communicator Error data from the
+1 ; response file if it exists
+2 ;
+3 NEW RESP,RESPDATA,ERRTXT,IBY,IBLINE,ERRDATA,FUTDT,TQIEN,IBERR,IBCT
+4 SET RESP=$ORDER(^IBCN(365,"AF",IBBUFDA,""),-1)
+5 IF 'RESP
GOTO ECERRX
+6 SET RESPDATA=$GET(^IBCN(365,RESP,1))
+7 SET ERRTXT=$PIECE($GET(^IBCN(365,RESP,4)),U,1)
+8 ; Trans Queue file ien
SET TQIEN=+$PIECE($GET(^IBCN(365,RESP,0)),U,5)
+9 ; Future date to transmit
SET FUTDT=$PIECE($GET(^IBCN(365.1,TQIEN,0)),U,9)
+10 IF '$PIECE(RESPDATA,U,14)
IF '$PIECE(RESPDATA,U,15)
IF ERRTXT=""
IF 'FUTDT
GOTO ECERRX
+11 ;
+12 ; At this point, we know there's something to get displayed
+13 ;
+14 ; Display section header
+15 DO SET^IBCNBLE(" ")
+16 SET IBY=$JUSTIFY("",19)_"Eligibility Communicator Error Information"
+17 DO SET^IBCNBLE(IBY,"B")
SET IBLINE=""
+18 ;
+19 ; Display Error Condition data - field# 1.14
+20 IF $PIECE(RESPDATA,U,14)
Begin DoDot:1
+21 SET ERRDATA=$GET(^IBE(365.017,$PIECE(RESPDATA,U,14),0))
+22 KILL IBERR
+23 SET IBERR(1)=$PIECE(ERRDATA,U,2)_" (Error Condition '"_$PIECE(ERRDATA,U,1)_"')"
+24 DO TXT^IBCNEUT7("IBERR")
+25 FOR IBCT=1:1:$ORDER(IBERR(""),-1)
DO SET^IBCNBLE(IBERR(IBCT))
+26 QUIT
End DoDot:1
+27 ;
+28 ; Display Error Action data - field# 1.15
+29 IF $PIECE(RESPDATA,U,15)
Begin DoDot:1
+30 SET ERRDATA=$GET(^IBE(365.018,$PIECE(RESPDATA,U,15),0))
+31 KILL IBERR
+32 SET IBERR(1)=$PIECE(ERRDATA,U,2)_" (Error Action '"_$PIECE(ERRDATA,U,1)_"')"
+33 DO TXT^IBCNEUT7("IBERR")
+34 FOR IBCT=1:1:$ORDER(IBERR(""),-1)
DO SET^IBCNBLE(IBERR(IBCT))
+35 QUIT
End DoDot:1
+36 ;
+37 ; Display Error Text data - field# 4.01
+38 IF ERRTXT'=""
DO SET^IBCNBLE(ERRTXT)
+39 ;
+40 ; Display Date of Future Transmission - field# .09 in file 365.1
+41 IF FUTDT
Begin DoDot:1
+42 SET FUTDT=$$FMTE^XLFDT(FUTDT,"5Z")
+43 DO SET^IBCNBLE(" ")
+44 SET IBLINE=" Date of Future Transmission: "_FUTDT
+45 DO SET^IBCNBLE(IBLINE)
SET IBLINE=""
+46 QUIT
End DoDot:1
ECERRX ;
+1 QUIT
+2 ;
ECNOTE(IBBUFDA) ; IB*2*601/DM
+1 NEW IBRIEN,IBD1,IBMSG,IB1ST,IBTXT,IBCT
+2 IF '$$MBICHK^IBCNEUT7(IBBUFDA)
GOTO ECNOTEX
+3 SET IBRIEN=$ORDER(^IBCN(365,"AF",IBBUFDA,""),-1)
+4 IF 'IBRIEN
GOTO ECNOTEX
+5 SET IB1ST=1
+6 SET IBD1=0
+7 FOR
SET IBD1=$ORDER(^IBCN(365,IBRIEN,6,IBD1))
if 'IBD1
QUIT
Begin DoDot:1
+8 SET IBMSG=0
+9 FOR
SET IBMSG=$ORDER(^IBCN(365,IBRIEN,6,IBD1,1,IBMSG))
if 'IBMSG
QUIT
Begin DoDot:2
+10 SET IBTXT(1)=^IBCN(365,IBRIEN,6,IBD1,1,IBMSG,0)
+11 IF IB1ST
Begin DoDot:3
+12 SET IB1ST=0
+13 ; Display section header
+14 DO SET^IBCNBLE(" ")
+15 SET IBY=$JUSTIFY("",19)_"Eligibility Communicator Notes"
+16 DO SET^IBCNBLE(IBY,"B")
SET IBLINE=""
End DoDot:3
+17 ; Display Notes
+18 DO TXT^IBCNEUT7("IBTXT")
+19 FOR IBCT=1:1:$ORDER(IBTXT(""),-1)
DO SET^IBCNBLE(IBTXT(IBCT))
+20 QUIT
End DoDot:2
End DoDot:1
+21 ;
ECNOTEX ;
+1 QUIT
+2 ;
SIDERR(BUF,PIEN) ;
+1 ; dw/IB*668 updated utility as the logic was using a field that was made
+2 ; obsolete many years ago. It may no longer try to use SSN for the subscriber ID
+3 ;
+4 ; If Subscriber ID is required and SSN cannot be substituted
+5 ; and buffer does not have a sub id -> return error
+6 ; BUF = buffer IEN
+7 ; PIEN = payer IEN
+8 ;
+9 NEW ERR,SID,APPIEN,SIDREQ
+10 SET ERR=""
+11 ;S SID=$P($G(^IBA(355.33,BUF,60)),U,4) ; Patch 516 - baa
+12 ; Patch 516 - baa
SET SID=$$GET1^DIQ(355.33,BUF,90.03)
+13 ; Subscriber id is populated, further checking is moot
IF SID]""
GOTO SIDX
+14 ;IB*668/TAZ - Changed Payer Application from IIV to EIV
+15 SET APPIEN=$$PYRAPP^IBCNEUT5("EIV",PIEN)
+16 ;S SIDSTR=$G(^IBE(365.12,PIEN,1,APPIEN,0)) ;dw/668 field was moved
+17 ;S SIDREQ=$P(SIDSTR,U,8) I 'SIDREQ G SIDX ; if sub id is not req'd - ok
+18 ;S SIDSSN=$P(SIDSTR,U,9) I 'SIDSSN S ERR=18 ; if ssn cannot be used -> B15 status (IEN = 18)
+19 SET SIDREQ=$$GET1^DIQ(365.121,APPIEN_","_PIEN_",",4.02,"I")
+20 ; if sub id is not req'd - ok
IF 'SIDREQ
GOTO SIDX
+21 ; missing Subscriber ID and it is required -> B15 status (IEN = 18)
SET ERR=18
SIDX QUIT ERR
+1 ;
PIDERR(BUF) ;
+1 ; If patient is a dependent and patient id is missing return error
+2 ; BUF - buffer ien
+3 ;
+4 NEW ERR,PREL
+5 SET ERR=""
+6 SET PREL=$PIECE($GET(^IBA(355.33,BUF,60)),U,14)
+7 IF PREL'=18
IF PREL'=""
IF $PIECE($GET(^IBA(355.33,BUF,62)),U)=""
SET ERR=23
+8 QUIT ERR
