IBECEA39 ;EDE/WCJ-Multi-site maintain UC VISIT TRACKING FILE (#351.82) - PULL; 2-DEC-19
;;2.0;INTEGRATED BILLING;**669,678,696**;21-MAR-94;Build 3
;;Per VA Directive 6402, this routine should not be modified.
;; DBIA#1621 %ZTER (ERROR RECORDING)
;; DBIA#2729 MESSAGE ACTION API
;; DBIA#4678 VAFCTFU GET TREATING LIST
;; DBIA#3144 DIRECT RPC CALLS
;; DBIA#3149 XWBDRPC
;
G AWAY
;
AWAY Q ;thought I was being figurative??? Guess again!
;
PULL ; This will be called from a menu option.
; ask the patient and if selected, initiate the pull
;
N IBDFN,IBPULLRESULTS
;
AGAIN Q:'$$GETPAT(.IBDFN)
;
D PATIENTPULL(IBDFN,.IBPULLRESULTS)
;
D DISPLAYRES(IBDFN,.IBPULLRESULTS)
;
K IBDFN,IBPULLRESULTS
G AGAIN ; I know, I know, it's a goto - please don't judge me
;
GETPAT(IBDFN) ; Select a patient.
; Return 0 - no patient selected
; Return 1 - patient selected
; IBDFN will be the patient's IEN in file 2
;
N DIC,X,Y
N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
S DIC="^DPT(",DIC(0)="AEMQ" D ^DIC S IBDFN=+Y
Q Y>0
;
PATIENTPULL(IBDFN,IBERR) ; This does a lot of the same stuff the push does only for a specific veteran.
; IBDFN - which patient
; IBERR - return array of results
;
K ^TMP("IBECEA_COPAY",$J) ; start fresh
;
N IBSITE,IBFAC,IBTFL,IBT,IBICN,IBH,IBX,IBR,IBHERE,IBC,IBZ
S IBERR=0
;
D SITE^IBAUTL ; returns IBSITE (external#) and IBFAC (internal#) based on IB SITE PARAMETERS for this site
S IBICN=$$ICN^IBARXMU(IBDFN)
I 'IBICN S IBERR=IBERR+1,IBERR(IBERR)="-1^Failed local ICN lookup." Q ; no ICN - leave in the index and try again tomorrow since people eventually get ICNs according the MPI documentation
S IBT=$$TFL^IBECEA37(IBDFN,IBSITE,.IBTFL)
I 'IBT S IBERR=IBERR+1,IBERR(IBERR)="-1^No record of Veteran being seen at other treating facilities (file #391.91)" Q ; not seen at other treating facilites so no where to send - done with entry
;
; send off calls to other treating facilities that this veteran has been seen at
; the calls fire off the RPC (stored procedure) at each site
S IBX=0 F S IBX=$O(IBTFL(IBX)) Q:IBX<1 D
. W !,"Now sending query to ",$P(IBTFL(IBX),"^",2)," ..."
. N IBH
. D EN1^XWB2HL7(.IBH,+IBTFL(IBX),"IBECEA COPAY SYNCH","",IBICN,IBSITE) ; push a request for all records for a patient (used when playing catch up - possibly adding a treating facility)
. ; check for handle
. I $G(IBH(0))="" D Q
.. S IBTFL(IBX,"ERR")="-1^No handle returned from RPC"
.. S IBERR=IBERR+1,IBERR(IBERR)="-1^No handle returned from RPC by site "_$P(IBTFL(IBX),"^",2)
. S $P(IBTFL(IBX),"^",3)=IBH(0) ; save handle for later.
;
; now lets look for the remote data
S IBX=0 F S IBX=$O(IBTFL(IBX)) Q:IBX<1 I '$D(IBTFL(IBX,"ERR")) D
. ;
. ; try up to 10 times for 2 seconds each (at each site)
. N IBR
. F IBC=1:1:10 D RPCCHK^XWB2HL7(.IBR,$P(IBTFL(IBX),U,3)) Q:$G(IBR(0))["Done" H 2
. ;
. ; If not done at one (or more) facility set a flag so it does not get removed from the index
. I $G(IBR(0))'["Done" S IBERR=IBERR+1,IBERR(IBERR)="-1^No reply from site "_+IBTFL(IBX)_"."
. ; if done get data.
. I $G(IBR(0))["Done" D
.. K IBR,IBHERE
.. W !,"Query to site "_+IBTFL(IBX)_" completed."
.. D RTNDATA^XWBDRPC(.IBHERE,$P(IBTFL(IBX),"^",3))
.. I $D(IBHERE)>10 D ; not sure if was success or failure so save for now
... S IBERR=IBERR+1
... M IBERR(IBERR,+IBTFL(IBX),"REC")=IBHERE
.. E D
... S IBERR=IBERR+1
... M IBERR(IBERR,+IBTFL(IBX),"ERR")=^TMP($J,"XWB")
... K ^TMP($J,"XWB")
.. D CLEAR^XWBDRPC(.IBZ,$P(IBTFL(IBX),"^",3))
;
Q
;
PARSEPULL(IBPD,IBDFN,ERR) ; parse the record being pulled from the originating site
; IBPD is a packed data array
; "IEN^.01I^.01^C2^.03I^.04I^.05^.06I^.07I^1.01I^C9"
; "ien at originating site^dfn at originating site^patient name^originating site^event date^status^bill #^reason^unique id^update^full icn"
; "2^7229593^LASTNAME,FIRSTNAME MIDDLE^529^3190814^2^442-K902Z6L^^^99999999999v999999"
; IBDFN is the patient that we asked for
; ERR is returned even if it's not an ERROR so kind of a misnomer.
;
; and then add it, update it, or punt.
;
N IBUID,IBOS,IBIEN,IBRETURN
;WCJ;IB696;date added variable
;N IBICN,IBED,IBST,IBRS,IBBN,IBEG,IBADDED,IBUPDATED
N IBICN,IBED,IBST,IBRS,IBBN,IBEG,IBADDED,IBUPDATED,IBDADDRS,IBDADDHERE
;
; get the patient from their ICN and compare for grins - probably undeeded code but kind of fun - don't ya think
S IBICN=$P(IBPD,U,11) ; ICN
I IBDFN'=+$$DFN^IBARXMU($G(IBICN)) S ERR(1)="-1^Something went horribly wrong." Q
;
; get unique identifier and if not there, make one.
S IBUID=$P(IBPD,U,9) ; unique ID
I IBUID="" D
. S IBOS=$P(IBPD,U,4) ; originating site
. S IBIEN=$P(IBPD,U) ; 351.82 IEN at originating site
. S IBUID=IBOS_"_"_IBIEN
;
I IBUID="" S ERR(1)="-1^No UNIQUE ID - this can't actually happen so not sure why I am coding for it." Q
;
S IBED=$P(IBPD,U,5) ; event date
S IBST=$P(IBPD,U,6) ; status
S IBBN=$P(IBPD,U,7) ; bill number
S IBRS=$P(IBPD,U,8) ; reason
S IBEG=$P(IBPD,U,12) ; eligibilty group
D
. N X
. S X=$P(IBPD,U,13)
. D ^%DT
. S IBDADDRS=$S(+Y:Y,1:"") ;date added to patient file at the Remote System
S IBDADDHERE=$$GET1^DIQ(2,IBDFN,.097,"I") ; date patient added to this system aka HERE.
;
;WCJ;IB696;checking if the event date was before the patient was added to the remote system
;I IBEG'=$$GETELGP^IBECEA36(IBDFN,IBED) D Q
I IBEG'=$$GETELGP^IBECEA36(IBDFN,IBED),$S('IBDADDHERE:1,IBED<IBDADDHERE:0,1:1) D Q
. N Y S Y=IBED X ^DD("DD")
. S ERR(1)="-1^Patient's eligibility group differs between sites for date of service "_Y_"."
. S ERR(2)="-1^Current Site = "_$$GETELGP^IBECEA36(IBDFN,IBED)
. S ERR(3)="-1^Site# "_$P(IBUID,"_")_" = "_IBEG
. Q
;
; see if the record is already here.
D FIND^DIC(351.82,"",".01;.02:99;.03I;.04I;.05;.06I;.07I;1.01I","QEPX",IBUID,"","AUID")
;
; found 1 so attempt to edit it
I +$G(^TMP("DILIST",$J,0))=1 D Q
. N IBDATA,IBIEN351P82
. S IBDATA=$G(^TMP("DILIST",$J,1,0))
. S IBIEN351P82=+IBDATA
. I $P(IBDATA,U,6)=IBST,$P(IBDATA,U,7)=IBBN,$P(IBDATA,U,8)=IBRS S ERR(1)="0^No changes requested" Q
. S IBUPDATED=$$UPDATE^IBECEA38(IBIEN351P82,IBST,IBBN,IBRS,0,.IBRETURN)
. I 'IBUPDATED D Q
.. N Y
.. S Y=IBED X ^DD("DD")
.. S ERR(1)="-1^Unable to ADD record from Originating site# "_$P(IBUID,"_")_" and date: "_Y
.. S:IBRETURN["MAX free" ERR(2)=-1_U_IBRETURN
. S ERR(1)="1^successfully updated" Q
. Q
;
; found "many" (could be two or a jillion). Should not happen now that we add a unique identifier (KEYWORDS: should + not + unique)
I +$G(^TMP("DILIST",$J,0))>1 D Q
. S ERR(1)="-1^Could not uniquely identify entry being updated - more than one match. Originating site# "_$P(IBUID,"_")_" and IEN:"_$P(IBUID,"_",2)
;
; no matches, feel free to add one
I '$G(^TMP("DILIST",$J,0)) D Q
. S IBADDED=$$ADD^IBECEA38(IBDFN,IBOS,IBED,IBST,IBBN,IBRS,0,IBUID,.IBRETURN)
. I 'IBADDED D Q
.. N Y
.. S Y=IBED X ^DD("DD")
.. S ERR(1)="-1^Unable to ADD record from Originating site# "_$P(IBUID,"_")_" and date: "_Y
.. S:IBRETURN["MAX free" ERR(2)=-1_U_IBRETURN
. S ERR(1)="1^successfully added" Q
. Q
Q
;
DISPLAYRES(IBDFN,IBPULLRESULTS) ; display results
N ARR,IBDATA,IBCNT,IBMAX,IBOUT
S ARR="IBPULLRESULTS",IBCNT=1,IBMAX=10,IBOUT=0
F S ARR=$Q(@ARR) Q:ARR="" D Q:IBOUT
. I ARR["REC" D Q
.. I ARR["""REC"")" Q
.. I ARR[",0)" Q ; don't need 0 node, info only - IBPULLRESULTS(1,529,"REC",0)="23^*^0^"
.. I ARR[",1)" Q ; don't need 1 node, info only - IBPULLRESULTS(1,529,"REC",1)="IEN^.01I^.01^C2^.03I^.04I^.05^.06I^.07I^1.01I^.08"
.. N IBPULLDATA,IBERR
.. S IBPULLDATA=$G(@ARR)
.. D PARSEPULL(IBPULLDATA,IBDFN,.IBERR) ; parse data coming back - IBPULLRESULTS(1,529,"REC",2)="2^7229593^LASTNAME,FIRSTNAME MIDDLE^529^3190814^2^442-K902Z6L^^^0^1234567890V123456^8"
.. I $P($G(IBERR(1)),U)<0 D
... N I S I=0 F S I=$O(IBERR(I)) Q:'I S IBOUT=$$WRITE($P(IBERR(I),U,2,999),.IBCNT) Q:+IBOUT
. S IBDATA=$G(@ARR)
. S:IBDATA[U IBDATA=$P(IBDATA,U,2,999)
. I IBDATA]"" S IBOUT=$$WRITE(IBDATA,.IBCNT)
W !!
Q
;
WRITE(DATA,CNT) ;
N DIRUT,DIROUT
W !,DATA
I '(CNT#20) D PAUSE^VALM1
S CNT=$G(CNT)+1
Q $G(DIRUT)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBECEA39 8338 printed Sep 23, 2025@19:57:40 Page 2
IBECEA39 ;EDE/WCJ-Multi-site maintain UC VISIT TRACKING FILE (#351.82) - PULL; 2-DEC-19
+1 ;;2.0;INTEGRATED BILLING;**669,678,696**;21-MAR-94;Build 3
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;; DBIA#1621 %ZTER (ERROR RECORDING)
+4 ;; DBIA#2729 MESSAGE ACTION API
+5 ;; DBIA#4678 VAFCTFU GET TREATING LIST
+6 ;; DBIA#3144 DIRECT RPC CALLS
+7 ;; DBIA#3149 XWBDRPC
+8 ;
+9 GOTO AWAY
+10 ;
AWAY ;thought I was being figurative??? Guess again!
QUIT
+1 ;
PULL ; This will be called from a menu option.
+1 ; ask the patient and if selected, initiate the pull
+2 ;
+3 NEW IBDFN,IBPULLRESULTS
+4 ;
AGAIN if '$$GETPAT(.IBDFN)
QUIT
+1 ;
+2 DO PATIENTPULL(IBDFN,.IBPULLRESULTS)
+3 ;
+4 DO DISPLAYRES(IBDFN,.IBPULLRESULTS)
+5 ;
+6 KILL IBDFN,IBPULLRESULTS
+7 ; I know, I know, it's a goto - please don't judge me
GOTO AGAIN
+8 ;
GETPAT(IBDFN) ; Select a patient.
+1 ; Return 0 - no patient selected
+2 ; Return 1 - patient selected
+3 ; IBDFN will be the patient's IEN in file 2
+4 ;
+5 NEW DIC,X,Y
+6 ;Suppress PATIENT file fuzzy lookups
NEW DPTNOFZY
SET DPTNOFZY=1
+7 SET DIC="^DPT("
SET DIC(0)="AEMQ"
DO ^DIC
SET IBDFN=+Y
+8 QUIT Y>0
+9 ;
PATIENTPULL(IBDFN,IBERR) ; This does a lot of the same stuff the push does only for a specific veteran.
+1 ; IBDFN - which patient
+2 ; IBERR - return array of results
+3 ;
+4 ; start fresh
KILL ^TMP("IBECEA_COPAY",$JOB)
+5 ;
+6 NEW IBSITE,IBFAC,IBTFL,IBT,IBICN,IBH,IBX,IBR,IBHERE,IBC,IBZ
+7 SET IBERR=0
+8 ;
+9 ; returns IBSITE (external#) and IBFAC (internal#) based on IB SITE PARAMETERS for this site
DO SITE^IBAUTL
+10 SET IBICN=$$ICN^IBARXMU(IBDFN)
+11 ; no ICN - leave in the index and try again tomorrow since people eventually get ICNs according the MPI documentation
IF 'IBICN
SET IBERR=IBERR+1
SET IBERR(IBERR)="-1^Failed local ICN lookup."
QUIT
+12 SET IBT=$$TFL^IBECEA37(IBDFN,IBSITE,.IBTFL)
+13 ; not seen at other treating facilites so no where to send - done with entry
IF 'IBT
SET IBERR=IBERR+1
SET IBERR(IBERR)="-1^No record of Veteran being seen at other treating facilities (file #391.91)"
QUIT
+14 ;
+15 ; send off calls to other treating facilities that this veteran has been seen at
+16 ; the calls fire off the RPC (stored procedure) at each site
+17 SET IBX=0
FOR
SET IBX=$ORDER(IBTFL(IBX))
if IBX<1
QUIT
Begin DoDot:1
+18 WRITE !,"Now sending query to ",$PIECE(IBTFL(IBX),"^",2)," ..."
+19 NEW IBH
+20 ; push a request for all records for a patient (used when playing catch up - possibly adding a treating facility)
DO EN1^XWB2HL7(.IBH,+IBTFL(IBX),"IBECEA COPAY SYNCH","",IBICN,IBSITE)
+21 ; check for handle
+22 IF $GET(IBH(0))=""
Begin DoDot:2
+23 SET IBTFL(IBX,"ERR")="-1^No handle returned from RPC"
+24 SET IBERR=IBERR+1
SET IBERR(IBERR)="-1^No handle returned from RPC by site "_$PIECE(IBTFL(IBX),"^",2)
End DoDot:2
QUIT
+25 ; save handle for later.
SET $PIECE(IBTFL(IBX),"^",3)=IBH(0)
End DoDot:1
+26 ;
+27 ; now lets look for the remote data
+28 SET IBX=0
FOR
SET IBX=$ORDER(IBTFL(IBX))
if IBX<1
QUIT
IF '$DATA(IBTFL(IBX,"ERR"))
Begin DoDot:1
+29 ;
+30 ; try up to 10 times for 2 seconds each (at each site)
+31 NEW IBR
+32 FOR IBC=1:1:10
DO RPCCHK^XWB2HL7(.IBR,$PIECE(IBTFL(IBX),U,3))
if $GET(IBR(0))["Done"
QUIT
HANG 2
+33 ;
+34 ; If not done at one (or more) facility set a flag so it does not get removed from the index
+35 IF $GET(IBR(0))'["Done"
SET IBERR=IBERR+1
SET IBERR(IBERR)="-1^No reply from site "_+IBTFL(IBX)_"."
+36 ; if done get data.
+37 IF $GET(IBR(0))["Done"
Begin DoDot:2
+38 KILL IBR,IBHERE
+39 WRITE !,"Query to site "_+IBTFL(IBX)_" completed."
+40 DO RTNDATA^XWBDRPC(.IBHERE,$PIECE(IBTFL(IBX),"^",3))
+41 ; not sure if was success or failure so save for now
IF $DATA(IBHERE)>10
Begin DoDot:3
+42 SET IBERR=IBERR+1
+43 MERGE IBERR(IBERR,+IBTFL(IBX),"REC")=IBHERE
End DoDot:3
+44 IF '$TEST
Begin DoDot:3
+45 SET IBERR=IBERR+1
+46 MERGE IBERR(IBERR,+IBTFL(IBX),"ERR")=^TMP($JOB,"XWB")
+47 KILL ^TMP($JOB,"XWB")
End DoDot:3
+48 DO CLEAR^XWBDRPC(.IBZ,$PIECE(IBTFL(IBX),"^",3))
End DoDot:2
End DoDot:1
+49 ;
+50 QUIT
+51 ;
PARSEPULL(IBPD,IBDFN,ERR) ; parse the record being pulled from the originating site
+1 ; IBPD is a packed data array
+2 ; "IEN^.01I^.01^C2^.03I^.04I^.05^.06I^.07I^1.01I^C9"
+3 ; "ien at originating site^dfn at originating site^patient name^originating site^event date^status^bill #^reason^unique id^update^full icn"
+4 ; "2^7229593^LASTNAME,FIRSTNAME MIDDLE^529^3190814^2^442-K902Z6L^^^99999999999v999999"
+5 ; IBDFN is the patient that we asked for
+6 ; ERR is returned even if it's not an ERROR so kind of a misnomer.
+7 ;
+8 ; and then add it, update it, or punt.
+9 ;
+10 NEW IBUID,IBOS,IBIEN,IBRETURN
+11 ;WCJ;IB696;date added variable
+12 ;N IBICN,IBED,IBST,IBRS,IBBN,IBEG,IBADDED,IBUPDATED
+13 NEW IBICN,IBED,IBST,IBRS,IBBN,IBEG,IBADDED,IBUPDATED,IBDADDRS,IBDADDHERE
+14 ;
+15 ; get the patient from their ICN and compare for grins - probably undeeded code but kind of fun - don't ya think
+16 ; ICN
SET IBICN=$PIECE(IBPD,U,11)
+17 IF IBDFN'=+$$DFN^IBARXMU($GET(IBICN))
SET ERR(1)="-1^Something went horribly wrong."
QUIT
+18 ;
+19 ; get unique identifier and if not there, make one.
+20 ; unique ID
SET IBUID=$PIECE(IBPD,U,9)
+21 IF IBUID=""
Begin DoDot:1
+22 ; originating site
SET IBOS=$PIECE(IBPD,U,4)
+23 ; 351.82 IEN at originating site
SET IBIEN=$PIECE(IBPD,U)
+24 SET IBUID=IBOS_"_"_IBIEN
End DoDot:1
+25 ;
+26 IF IBUID=""
SET ERR(1)="-1^No UNIQUE ID - this can't actually happen so not sure why I am coding for it."
QUIT
+27 ;
+28 ; event date
SET IBED=$PIECE(IBPD,U,5)
+29 ; status
SET IBST=$PIECE(IBPD,U,6)
+30 ; bill number
SET IBBN=$PIECE(IBPD,U,7)
+31 ; reason
SET IBRS=$PIECE(IBPD,U,8)
+32 ; eligibilty group
SET IBEG=$PIECE(IBPD,U,12)
+33 Begin DoDot:1
+34 NEW X
+35 SET X=$PIECE(IBPD,U,13)
+36 DO ^%DT
+37 ;date added to patient file at the Remote System
SET IBDADDRS=$SELECT(+Y:Y,1:"")
End DoDot:1
+38 ; date patient added to this system aka HERE.
SET IBDADDHERE=$$GET1^DIQ(2,IBDFN,.097,"I")
+39 ;
+40 ;WCJ;IB696;checking if the event date was before the patient was added to the remote system
+41 ;I IBEG'=$$GETELGP^IBECEA36(IBDFN,IBED) D Q
+42 IF IBEG'=$$GETELGP^IBECEA36(IBDFN,IBED)
IF $SELECT('IBDADDHERE:1,IBED<IBDADDHERE:0,1:1)
Begin DoDot:1
+43 NEW Y
SET Y=IBED
XECUTE ^DD("DD")
+44 SET ERR(1)="-1^Patient's eligibility group differs between sites for date of service "_Y_"."
+45 SET ERR(2)="-1^Current Site = "_$$GETELGP^IBECEA36(IBDFN,IBED)
+46 SET ERR(3)="-1^Site# "_$PIECE(IBUID,"_")_" = "_IBEG
+47 QUIT
End DoDot:1
QUIT
+48 ;
+49 ; see if the record is already here.
+50 DO FIND^DIC(351.82,"",".01;.02:99;.03I;.04I;.05;.06I;.07I;1.01I","QEPX",IBUID,"","AUID")
+51 ;
+52 ; found 1 so attempt to edit it
+53 IF +$GET(^TMP("DILIST",$JOB,0))=1
Begin DoDot:1
+54 NEW IBDATA,IBIEN351P82
+55 SET IBDATA=$GET(^TMP("DILIST",$JOB,1,0))
+56 SET IBIEN351P82=+IBDATA
+57 IF $PIECE(IBDATA,U,6)=IBST
IF $PIECE(IBDATA,U,7)=IBBN
IF $PIECE(IBDATA,U,8)=IBRS
SET ERR(1)="0^No changes requested"
QUIT
+58 SET IBUPDATED=$$UPDATE^IBECEA38(IBIEN351P82,IBST,IBBN,IBRS,0,.IBRETURN)
+59 IF 'IBUPDATED
Begin DoDot:2
+60 NEW Y
+61 SET Y=IBED
XECUTE ^DD("DD")
+62 SET ERR(1)="-1^Unable to ADD record from Originating site# "_$PIECE(IBUID,"_")_" and date: "_Y
+63 if IBRETURN["MAX free"
SET ERR(2)=-1_U_IBRETURN
End DoDot:2
QUIT
+64 SET ERR(1)="1^successfully updated"
QUIT
+65 QUIT
End DoDot:1
QUIT
+66 ;
+67 ; found "many" (could be two or a jillion). Should not happen now that we add a unique identifier (KEYWORDS: should + not + unique)
+68 IF +$GET(^TMP("DILIST",$JOB,0))>1
Begin DoDot:1
+69 SET ERR(1)="-1^Could not uniquely identify entry being updated - more than one match. Originating site# "_$PIECE(IBUID,"_")_" and IEN:"_$PIECE(IBUID,"_",2)
End DoDot:1
QUIT
+70 ;
+71 ; no matches, feel free to add one
+72 IF '$GET(^TMP("DILIST",$JOB,0))
Begin DoDot:1
+73 SET IBADDED=$$ADD^IBECEA38(IBDFN,IBOS,IBED,IBST,IBBN,IBRS,0,IBUID,.IBRETURN)
+74 IF 'IBADDED
Begin DoDot:2
+75 NEW Y
+76 SET Y=IBED
XECUTE ^DD("DD")
+77 SET ERR(1)="-1^Unable to ADD record from Originating site# "_$PIECE(IBUID,"_")_" and date: "_Y
+78 if IBRETURN["MAX free"
SET ERR(2)=-1_U_IBRETURN
End DoDot:2
QUIT
+79 SET ERR(1)="1^successfully added"
QUIT
+80 QUIT
End DoDot:1
QUIT
+81 QUIT
+82 ;
DISPLAYRES(IBDFN,IBPULLRESULTS) ; display results
+1 NEW ARR,IBDATA,IBCNT,IBMAX,IBOUT
+2 SET ARR="IBPULLRESULTS"
SET IBCNT=1
SET IBMAX=10
SET IBOUT=0
+3 FOR
SET ARR=$QUERY(@ARR)
if ARR=""
QUIT
Begin DoDot:1
+4 IF ARR["REC"
Begin DoDot:2
+5 IF ARR["""REC"")"
QUIT
+6 ; don't need 0 node, info only - IBPULLRESULTS(1,529,"REC",0)="23^*^0^"
IF ARR[",0)"
QUIT
+7 ; don't need 1 node, info only - IBPULLRESULTS(1,529,"REC",1)="IEN^.01I^.01^C2^.03I^.04I^.05^.06I^.07I^1.01I^.08"
IF ARR[",1)"
QUIT
+8 NEW IBPULLDATA,IBERR
+9 SET IBPULLDATA=$GET(@ARR)
+10 ; parse data coming back - IBPULLRESULTS(1,529,"REC",2)="2^7229593^LASTNAME,FIRSTNAME MIDDLE^529^3190814^2^442-K902Z6L^^^0^1234567890V123456^8"
DO PARSEPULL(IBPULLDATA,IBDFN,.IBERR)
+11 IF $PIECE($GET(IBERR(1)),U)<0
Begin DoDot:3
+12 NEW I
SET I=0
FOR
SET I=$ORDER(IBERR(I))
if 'I
QUIT
SET IBOUT=$$WRITE($PIECE(IBERR(I),U,2,999),.IBCNT)
if +IBOUT
QUIT
End DoDot:3
End DoDot:2
QUIT
+13 SET IBDATA=$GET(@ARR)
+14 if IBDATA[U
SET IBDATA=$PIECE(IBDATA,U,2,999)
+15 IF IBDATA]""
SET IBOUT=$$WRITE(IBDATA,.IBCNT)
End DoDot:1
if IBOUT
QUIT
+16 WRITE !!
+17 QUIT
+18 ;
WRITE(DATA,CNT) ;
+1 NEW DIRUT,DIROUT
+2 WRITE !,DATA
+3 IF '(CNT#20)
DO PAUSE^VALM1
+4 SET CNT=$GET(CNT)+1
+5 QUIT $GET(DIRUT)
