MPIFRES ;SF/CMC-LOCAL AND MISSING ICN RESOLUTION ; 7/22/15 1:22pm
;;1.0;MASTER PATIENT INDEX VISTA;**1,7,10,15,17,21,26,28,33,35,43,39,52,54,61,73**;30 Apr 99;Build 1
;
; Integration Agreements Utilized:
; EXC, START and STOP^RGHLLOG - #2796
; ^DPT("AICNL", ^DPT("AMPIMIS" - #2070
; ^RGHL7(991.1 - #3259
; ^RGSITE - #2746
;
BKG ;
I $D(ZTQUEUED) D GO Q
S ZTRTN="GO^MPIFRES",ZTDESC="USE HL7 MSGS AND MAIL TO BUILD ICN"
S ZTIO="",ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,0,0,1,0)
I $D(DUZ) S ZTSAVE("DUZ")=DUZ
D ^%ZTLOAD
D HOME^%ZIS K IO("Q")
K ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,%
Q
;
GO ;ENTRY POINT
N MPIMORE,MPITOT
L +^XTMP("MPIF RESOLUTION"):3 E Q
I $D(ZTQUEUED) S ZTREQ="@"
;
K ^TMP("HLS",$J),STOP
D START^RGHLLOG()
D HLRDF
I $D(STOP) K STOP Q ;patch 7 added to quit if init returned an error
D LOOP
I $D(^TMP("HLS",$J)) D SEND
D STOP^RGHLLOG(0)
;**61 Story 173992 (ckn)
;Process MPIF EXPLICIT QUEUE
D PEXQUE
K MPIIT,MPITOT,HLDT,HLDT1,MPICNT,MPIDNUM,MPIEROR,MPIMIDT,MPIMSH
K MPIOUT,MPIQRYNM,MPISEQ,QCNT,MPIMCNT,MPIMTX,ENDT,MPIFRES
L -^XTMP("MPIF RESOLUTION")
; mark job completion date/time
S $P(^RGSITE(991.8,1,0),"^",4)=$$NOW^XLFDT
Q
;
HLRDF ;
S (MPIOUT,MPIMCNT)=""
S HL("ECH")="^~\&"
S HL("FS")="|"
D INIT^HLFNC2("MPIF ICN-Q02 SERVER",.HL)
I $O(HL("")) D EXC^RGHLLOG(220,"INIT^HLFNC2 call error returned") S STOP="" Q
D CREATE^HLTF(.MPIMCNT,.MPIMTX,.HLDT,.HLDT1)
Q
LOOP ;
S (MPICNT,MPIDNUM)=1
D MAKE
Q
SEND ;ready to send
D GENERATE^HLMA("MPIF ICN-Q02 SERVER","GB",1,.MPIMTX,.MPIEROR,.MPIMORE)
I +MPIEROR=0 D EXC^RGHLLOG(220,"GENERATE^HLMA call returned error") Q
K %,MPIMTX,MPIEROR,MPIMORE
K ^TMP("HLS",$J)
Q
MAKE ;
N LOCAL,MPIIT,TICN,STOP,X,Y,%,%H,%I,TODAY,SITE,XX,SDT,NDT
S LOCAL="",MPIIT=0,MPIFRES="",SITE=$P($$SITE^VASITE(),"^",3)
D NOW^%DTC S TODAY=X
;local ICNs
F S MPIIT=$O(^DPT("AICNL",1,MPIIT)) Q:MPIIT="" D
.;**61 - Story 173992 (ckn)
.;If DFN entry exist in new MPIF EXPLICIT ADD QUEUE, Don't process
.;this DFN as it will be processed by PEXQUE code
.I $D(^XTMP("MPIF EXPLICIT QUEUE",MPIIT)) Q
.; LINE BELOW ADDED FOR PATCH 26 TO CLEANUP AICNL X-REF WHEN LEFT AROUND
.I $E($$GETICN^MPIF001(MPIIT),1,3)'=SITE S XX=$$SETLOC^MPIF001(MPIIT,0) K ^DPT("AICNL",1,MPIIT) Q
.;Q:+$G(^DPT("AICNL",1,MPIIT))=1 **39 changing check
.Q:+$G(^DPT("AICNL",1,MPIIT))=2&($P($G(^DPT("AICNL",1,MPIIT)),"^",2)=TODAY)
.; ^ check if A28 failed to get ICN back and should now be sent up
.; DON'T send if is the 2^today **35
.S SDT=$P($G(^DPT("AICNL",1,MPIIT)),"^",2)
.N X1,X2 K X S X1=SDT,X2=2 D C^%DTC S NDT=X ;**39 FIGURE 2 DAYS FROM NOW
.Q:+$G(^DPT("AICNL",1,MPIIT))=1&(SDT=TODAY)
.; **39 ^ if send up today don't send again
.Q:+$G(^DPT("AICNL",1,MPIIT))=1&(NDT>TODAY)
.;**39 ^ only send patient to MPI for Local ICN resolution 1 time UNLESS its day 3 since it was sent
.;I $D(^RGHL7(991.1,"ADFN",218,MPIIT)) S ^DPT("AICNL",1,MPIIT)="1^"_TODAY Q
.; ^ checking if potential match exception **43 REMOVE CHECK ON POTENTIAL MATCH EXCEPTIONS
.D MAKE3
;missing ICNs
S MPIIT=0
F S MPIIT=$O(^DPT("AMPIMIS",MPIIT)) Q:MPIIT="" D
.K STOP
.I $D(^DPT(MPIIT,-9)) K ^DPT("AMPIMIS",MPIIT) Q ;**43 CHECK IF MERGED PATIENT AND CLEANUP CROSS REFERENCE
.I '$D(^DPT(MPIIT,0)) K ^DPT("AMPIMIS",MPIIT) Q ;**54 cleanup for x-ref if 0 node doesn't exist
.S TICN=+$$GETICN^MPIF001(MPIIT)
.I TICN<0 L +^DPT(MPIIT):5 I '$T Q ;**35
.L -^DPT(MPIIT) ;**35 **52 UNLOCK WHAT IS LOCKED ABOVE
.;**35 If don't have ICN yet, try to lock if can't get lock skip record - still creating patient.
.I TICN<0,'$D(STOP) D MAKE3
.K ^DPT("AMPIMIS",MPIIT) ;**54 include cleanup for x-ref here
Q
MAKE3 ;
K MPIOUT
S MPIFRES=""
S:$G(MPIQRYNM)="" MPIQRYNM="EXACT_MATCH_QUERY" ;**43 changed MPIQRYNM from VTQ_PID_ICN_LOAD_1 to stop automatic add pts on the MPI
D VTQ1^MPIFVTQ(MPIIT,.MPIOUT,.HL,.MPIQRYNM)
;**54 MVI 874 STOP LOGGING EXCEPTION AS WE CORRECTED THE DANGLING X-REF FOR INVALID DFN
I $P(MPIOUT(0),"^")<0,$P(MPIOUT(0),"^",2)="invalid DFN" Q
I $P(MPIOUT(0),"^",2)="no encoding characters" D EXC^RGHLLOG(206,"DFN = "_MPIIT_" Problem with building VTQ was "_$P(MPIOUT(0),"^",2),MPIIT) Q
;I $P(MPIOUT(0),"^")<0,$P(MPIOUT(0),"^",2)="Missing Required Field(s)" Q
;Q:$P(MPIOUT(0),"^")<0
S ^DPT("AICNL",1,MPIIT)="1^"_TODAY
; ^ mark Local ICN as having been sent to MPI for resolution
;call for HL7 header
S MPIMIDT=MPIMCNT_"-"_MPIDNUM
D MSH^HLFNC2(.HL,MPIMIDT,.MPIMSH)
S MPIOUT(1)=MPIMSH
S ^TMP("HLS",$J,MPICNT)=MPIOUT(1)
S MPICNT=MPICNT+1
;MESSAGE BUILT
S MPISEQ=0
;setup VTQ segment in HL array
S ^TMP("HLS",$J,MPICNT)=MPIOUT(2)
S MPICNT=MPICNT+1
;setup RDF segment in HL array
S ^TMP("HLS",$J,MPICNT)=MPIOUT(3)
;loop through and add the additional RDF continuations
N SCNT,Y S Y=3,SCNT=1 F S Y=$O(MPIOUT(Y)) Q:'Y D
.S ^TMP("HLS",$J,MPICNT,SCNT)=MPIOUT(Y),SCNT=SCNT+1
S MPICNT=MPICNT+1
S MPIDNUM=MPIDNUM+1
I MPIDNUM>100 D
.D SEND
.S (MPICNT,MPIDNUM)=1
.D HLRDF
Q
PEXQUE ;Process MPIF EXPLICIT QUEUE for pending DFNs from Register A Patient option
N DFN,PATARR,MPIDATA,STNUM
S STNUM=$P($$SITE^VASITE(),"^",3)
I '$D(^XTMP("MPIF EXPLICIT QUEUE")) Q
S $P(^XTMP("MPIF EXPLICIT QUEUE",0),"^",1)=$$FMADD^XLFDT(DT,5)
S DFN=0 F S DFN=$O(^XTMP("MPIF EXPLICIT QUEUE",DFN)) Q:+DFN=0 D
. K PATARR
. I $P($G(^DPT(DFN,"MPI")),"^")'="",($E($P($G(^DPT(DFN,"MPI")),"^"),1,3)'=STNUM) D Q
.. K ^XTMP("MPIF EXPLICIT QUEUE",DFN)
. D GETPAT(DFN,.PATARR)
. ;Call webservice for explicit Add
. D GETICN^MPIFXMLI(.MPIDATA,.PATARR)
. I $G(MPIDATA("ICN"))<1 D Q ;No ICN returned - keep this record in queue
..S ^XTMP("MPIF EXPLICIT QUEUE",DFN)=DT_"^"_PATARR("AddType")_"^"_PATARR("mcid")_"^"_$G(MPIDATA("ERRTXT"))
..K MPIDATA,PATARR
. ;Store ICN into Patient file
. D VIC40^MPIFAPI(DFN,MPIDATA("ICN"))
. ;cleanup the queue
. K ^XTMP("MPIF EXPLICIT QUEUE",DFN),MPIDATA,PATARR
Q
GETPAT(DFN,PATARR) ;Get patient data for DFN
N NAME,DNM,VAROOT,COUNTRY,STATE,DGDEM,DGOPD,DGADDR,ADDTYP,STOKEN
S ADDTYP=$P($G(^XTMP("MPIF EXPLICIT QUEUE",DFN)),"^",2) ; Add type
S STOKEN=$P($G(^XTMP("MPIF EXPLICIT QUEUE",DFN)),"^",3) ;search token
S VAROOT="DGDEM" D DEM^VADPT ;Patient Demographic data
S VAROOT="DGOPD" D OPD^VADPT ;Patient Other Pertinent Data
S VAROOT="DGADDR" D ADD^VADPT ;Patient Address data
S PATARR("AddType")=$G(ADDTYP),PATARR("mcid")=STOKEN
;NAME
S DNM=$G(DGDEM(1)) I DNM'="" D
.D STDNAME^XLFNAME(.DNM,"C")
.S PATARR(1,"FirstName")=DNM("GIVEN"),PATARR(1,"Surname")=DNM("FAMILY")
.S PATARR(1,"MiddleName")=DNM("MIDDLE"),PATARR(1,"Suffix")=DNM("SUFFIX")
S PATARR(1,"SSN")=$P($G(DGDEM(2)),"^") ;SSN
S PATARR(1,"DOB")=$P($G(DGDEM(3)),"^") ;DOB
S PATARR(1,"Gender")=$P($G(DGDEM(5)),"^") ;Gender
S PATARR(1,"MMN")=$G(DGOPD(5)) ;Mother's maiden Name
S PATARR(1,"POBCity")=$G(DGOPD(1)) ;POB City
S PATARR(1,"POBState")=$P($G(DGOPD(2)),"^") I PATARR(1,"POBState")'="" S PATARR(1,"POBState")=$P($G(^DIC(5,PATARR(1,"POBState"),0)),"^",2) ;POB State
S PATARR(1,"MBI")=$P($G(^DPT(DFN,"MPIMB")),"^") ;Multiple Birth Indicator
S PATARR(1,"DOD")=$P($G(DGDEM(6)),"^") ;Date of Death
;Address Fields
S COUNTRY=$P($G(DGADDR(25)),"^")
I COUNTRY'="",($D(^HL(779.004,COUNTRY,0))) D
. S PATARR(1,"ResAddL1")=$G(DGADDR(1)),PATARR(1,"ResAddL2")=$G(DGADDR(2))
. S PATARR(1,"ResAddL3")=$G(DGADDR(3)),PATARR(1,"ResAddCity")=$G(DGADDR(4))
. S COUNTRY=$P($G(DGADDR(25)),"^"),COUNTRY=$P($G(^HL(779.004,COUNTRY,0)),"^")
. S PATARR(1,"ResAddCountry")=COUNTRY
. I COUNTRY="USA" D
.. S STATE=$P($G(DGADDR(5)),"^") I STATE'="" S PATARR(1,"ResAddState")=$P($G(^DIC(5,STATE,0)),"^",2)
.. S PATARR(1,"ResAddZip4")=$G(DGADDR(6))
.I COUNTRY'="USA" D
.. S PATARR(1,"ResAddProvince")=$G(DGADDR(23))
.. S PATARR(1,"ResAddPostalCode")=$G(DGADDR(24))
; Phone
S PATARR(1,"ResPhone")=$G(DGADDR(8))
S PATARR(1,"DFN")=DFN ;DFN of Patient
;**73, STORY 1218906 (dlr) - Start of Changes
S PATARR(1,"patientVeteran")=$P($G(^DPT(DFN,"VET")),"^")
S PATARR(1,"patientServiceConnected")=$P($G(^DPT(DFN,.3)),"^")
S PATARR(1,"patientType")=$$PATTYPE(DFN)
S PATARR(1,"ICN")=$$GETICN^MPIF001(DFN)
Q
PATTYPE(DFN) ;
N TYPEIEN,TYPE,RET
S RET=""
;
S TYPEIEN=$P($G(^DPT(DFN,"TYPE")),"^")
S TYPE=$P(^DG(391,TYPEIEN,0),"^")
I TYPE="ACTIVE DUTY" S RET=1
I TYPE="ALLIED VETERAN" S RET=2
I TYPE="COLLATERAL" S RET=3
I TYPE="EMPLOYEE" S RET=4
I TYPE="MILITARY RETIREE" S RET=5
I TYPE="NON-VETERAN (OTHER)" S RET=6
I TYPE="NSC VETERAN" S RET=7
I TYPE="SC VETERAN" S RET=8
I TYPE="TRICARE" S RET=9
Q RET
;**73, STORY 1218906 (dlr) - End Changes
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMPIFRES 8733 printed Apr 09, 2024@21:13:26 Page 2
MPIFRES ;SF/CMC-LOCAL AND MISSING ICN RESOLUTION ; 7/22/15 1:22pm
+1 ;;1.0;MASTER PATIENT INDEX VISTA;**1,7,10,15,17,21,26,28,33,35,43,39,52,54,61,73**;30 Apr 99;Build 1
+2 ;
+3 ; Integration Agreements Utilized:
+4 ; EXC, START and STOP^RGHLLOG - #2796
+5 ; ^DPT("AICNL", ^DPT("AMPIMIS" - #2070
+6 ; ^RGHL7(991.1 - #3259
+7 ; ^RGSITE - #2746
+8 ;
BKG ;
+1 IF $DATA(ZTQUEUED)
DO GO
QUIT
+2 SET ZTRTN="GO^MPIFRES"
SET ZTDESC="USE HL7 MSGS AND MAIL TO BUILD ICN"
+3 SET ZTIO=""
SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,0,0,1,0)
+4 IF $DATA(DUZ)
SET ZTSAVE("DUZ")=DUZ
+5 DO ^%ZTLOAD
+6 DO HOME^%ZIS
KILL IO("Q")
+7 KILL ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,%
+8 QUIT
+9 ;
GO ;ENTRY POINT
+1 NEW MPIMORE,MPITOT
+2 LOCK +^XTMP("MPIF RESOLUTION"):3
IF '$TEST
QUIT
+3 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 ;
+5 KILL ^TMP("HLS",$JOB),STOP
+6 DO START^RGHLLOG()
+7 DO HLRDF
+8 ;patch 7 added to quit if init returned an error
IF $DATA(STOP)
KILL STOP
QUIT
+9 DO LOOP
+10 IF $DATA(^TMP("HLS",$JOB))
DO SEND
+11 DO STOP^RGHLLOG(0)
+12 ;**61 Story 173992 (ckn)
+13 ;Process MPIF EXPLICIT QUEUE
+14 DO PEXQUE
+15 KILL MPIIT,MPITOT,HLDT,HLDT1,MPICNT,MPIDNUM,MPIEROR,MPIMIDT,MPIMSH
+16 KILL MPIOUT,MPIQRYNM,MPISEQ,QCNT,MPIMCNT,MPIMTX,ENDT,MPIFRES
+17 LOCK -^XTMP("MPIF RESOLUTION")
+18 ; mark job completion date/time
+19 SET $PIECE(^RGSITE(991.8,1,0),"^",4)=$$NOW^XLFDT
+20 QUIT
+21 ;
HLRDF ;
+1 SET (MPIOUT,MPIMCNT)=""
+2 SET HL("ECH")="^~\&"
+3 SET HL("FS")="|"
+4 DO INIT^HLFNC2("MPIF ICN-Q02 SERVER",.HL)
+5 IF $ORDER(HL(""))
DO EXC^RGHLLOG(220,"INIT^HLFNC2 call error returned")
SET STOP=""
QUIT
+6 DO CREATE^HLTF(.MPIMCNT,.MPIMTX,.HLDT,.HLDT1)
+7 QUIT
LOOP ;
+1 SET (MPICNT,MPIDNUM)=1
+2 DO MAKE
+3 QUIT
SEND ;ready to send
+1 DO GENERATE^HLMA("MPIF ICN-Q02 SERVER","GB",1,.MPIMTX,.MPIEROR,.MPIMORE)
+2 IF +MPIEROR=0
DO EXC^RGHLLOG(220,"GENERATE^HLMA call returned error")
QUIT
+3 KILL %,MPIMTX,MPIEROR,MPIMORE
+4 KILL ^TMP("HLS",$JOB)
+5 QUIT
MAKE ;
+1 NEW LOCAL,MPIIT,TICN,STOP,X,Y,%,%H,%I,TODAY,SITE,XX,SDT,NDT
+2 SET LOCAL=""
SET MPIIT=0
SET MPIFRES=""
SET SITE=$PIECE($$SITE^VASITE(),"^",3)
+3 DO NOW^%DTC
SET TODAY=X
+4 ;local ICNs
+5 FOR
SET MPIIT=$ORDER(^DPT("AICNL",1,MPIIT))
if MPIIT=""
QUIT
Begin DoDot:1
+6 ;**61 - Story 173992 (ckn)
+7 ;If DFN entry exist in new MPIF EXPLICIT ADD QUEUE, Don't process
+8 ;this DFN as it will be processed by PEXQUE code
+9 IF $DATA(^XTMP("MPIF EXPLICIT QUEUE",MPIIT))
QUIT
+10 ; LINE BELOW ADDED FOR PATCH 26 TO CLEANUP AICNL X-REF WHEN LEFT AROUND
+11 IF $EXTRACT($$GETICN^MPIF001(MPIIT),1,3)'=SITE
SET XX=$$SETLOC^MPIF001(MPIIT,0)
KILL ^DPT("AICNL",1,MPIIT)
QUIT
+12 ;Q:+$G(^DPT("AICNL",1,MPIIT))=1 **39 changing check
+13 if +$GET(^DPT("AICNL",1,MPIIT))=2&($PIECE($GET(^DPT("AICNL",1,MPIIT)),"^",2)=TODAY)
QUIT
+14 ; ^ check if A28 failed to get ICN back and should now be sent up
+15 ; DON'T send if is the 2^today **35
+16 SET SDT=$PIECE($GET(^DPT("AICNL",1,MPIIT)),"^",2)
+17 ;**39 FIGURE 2 DAYS FROM NOW
NEW X1,X2
KILL X
SET X1=SDT
SET X2=2
DO C^%DTC
SET NDT=X
+18 if +$GET(^DPT("AICNL",1,MPIIT))=1&(SDT=TODAY)
QUIT
+19 ; **39 ^ if send up today don't send again
+20 if +$GET(^DPT("AICNL",1,MPIIT))=1&(NDT>TODAY)
QUIT
+21 ;**39 ^ only send patient to MPI for Local ICN resolution 1 time UNLESS its day 3 since it was sent
+22 ;I $D(^RGHL7(991.1,"ADFN",218,MPIIT)) S ^DPT("AICNL",1,MPIIT)="1^"_TODAY Q
+23 ; ^ checking if potential match exception **43 REMOVE CHECK ON POTENTIAL MATCH EXCEPTIONS
+24 DO MAKE3
End DoDot:1
+25 ;missing ICNs
+26 SET MPIIT=0
+27 FOR
SET MPIIT=$ORDER(^DPT("AMPIMIS",MPIIT))
if MPIIT=""
QUIT
Begin DoDot:1
+28 KILL STOP
+29 ;**43 CHECK IF MERGED PATIENT AND CLEANUP CROSS REFERENCE
IF $DATA(^DPT(MPIIT,-9))
KILL ^DPT("AMPIMIS",MPIIT)
QUIT
+30 ;**54 cleanup for x-ref if 0 node doesn't exist
IF '$DATA(^DPT(MPIIT,0))
KILL ^DPT("AMPIMIS",MPIIT)
QUIT
+31 SET TICN=+$$GETICN^MPIF001(MPIIT)
+32 ;**35
IF TICN<0
LOCK +^DPT(MPIIT):5
IF '$TEST
QUIT
+33 ;**35 **52 UNLOCK WHAT IS LOCKED ABOVE
LOCK -^DPT(MPIIT)
+34 ;**35 If don't have ICN yet, try to lock if can't get lock skip record - still creating patient.
+35 IF TICN<0
IF '$DATA(STOP)
DO MAKE3
+36 ;**54 include cleanup for x-ref here
KILL ^DPT("AMPIMIS",MPIIT)
End DoDot:1
+37 QUIT
MAKE3 ;
+1 KILL MPIOUT
+2 SET MPIFRES=""
+3 ;**43 changed MPIQRYNM from VTQ_PID_ICN_LOAD_1 to stop automatic add pts on the MPI
if $GET(MPIQRYNM)=""
SET MPIQRYNM="EXACT_MATCH_QUERY"
+4 DO VTQ1^MPIFVTQ(MPIIT,.MPIOUT,.HL,.MPIQRYNM)
+5 ;**54 MVI 874 STOP LOGGING EXCEPTION AS WE CORRECTED THE DANGLING X-REF FOR INVALID DFN
+6 IF $PIECE(MPIOUT(0),"^")<0
IF $PIECE(MPIOUT(0),"^",2)="invalid DFN"
QUIT
+7 IF $PIECE(MPIOUT(0),"^",2)="no encoding characters"
DO EXC^RGHLLOG(206,"DFN = "_MPIIT_" Problem with building VTQ was "_$PIECE(MPIOUT(0),"^",2),MPIIT)
QUIT
+8 ;I $P(MPIOUT(0),"^")<0,$P(MPIOUT(0),"^",2)="Missing Required Field(s)" Q
+9 ;Q:$P(MPIOUT(0),"^")<0
+10 SET ^DPT("AICNL",1,MPIIT)="1^"_TODAY
+11 ; ^ mark Local ICN as having been sent to MPI for resolution
+12 ;call for HL7 header
+13 SET MPIMIDT=MPIMCNT_"-"_MPIDNUM
+14 DO MSH^HLFNC2(.HL,MPIMIDT,.MPIMSH)
+15 SET MPIOUT(1)=MPIMSH
+16 SET ^TMP("HLS",$JOB,MPICNT)=MPIOUT(1)
+17 SET MPICNT=MPICNT+1
+18 ;MESSAGE BUILT
+19 SET MPISEQ=0
+20 ;setup VTQ segment in HL array
+21 SET ^TMP("HLS",$JOB,MPICNT)=MPIOUT(2)
+22 SET MPICNT=MPICNT+1
+23 ;setup RDF segment in HL array
+24 SET ^TMP("HLS",$JOB,MPICNT)=MPIOUT(3)
+25 ;loop through and add the additional RDF continuations
+26 NEW SCNT,Y
SET Y=3
SET SCNT=1
FOR
SET Y=$ORDER(MPIOUT(Y))
if 'Y
QUIT
Begin DoDot:1
+27 SET ^TMP("HLS",$JOB,MPICNT,SCNT)=MPIOUT(Y)
SET SCNT=SCNT+1
End DoDot:1
+28 SET MPICNT=MPICNT+1
+29 SET MPIDNUM=MPIDNUM+1
+30 IF MPIDNUM>100
Begin DoDot:1
+31 DO SEND
+32 SET (MPICNT,MPIDNUM)=1
+33 DO HLRDF
End DoDot:1
+34 QUIT
PEXQUE ;Process MPIF EXPLICIT QUEUE for pending DFNs from Register A Patient option
+1 NEW DFN,PATARR,MPIDATA,STNUM
+2 SET STNUM=$PIECE($$SITE^VASITE(),"^",3)
+3 IF '$DATA(^XTMP("MPIF EXPLICIT QUEUE"))
QUIT
+4 SET $PIECE(^XTMP("MPIF EXPLICIT QUEUE",0),"^",1)=$$FMADD^XLFDT(DT,5)
+5 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("MPIF EXPLICIT QUEUE",DFN))
if +DFN=0
QUIT
Begin DoDot:1
+6 KILL PATARR
+7 IF $PIECE($GET(^DPT(DFN,"MPI")),"^")'=""
IF ($EXTRACT($PIECE($GET(^DPT(DFN,"MPI")),"^"),1,3)'=STNUM)
Begin DoDot:2
+8 KILL ^XTMP("MPIF EXPLICIT QUEUE",DFN)
End DoDot:2
QUIT
+9 DO GETPAT(DFN,.PATARR)
+10 ;Call webservice for explicit Add
+11 DO GETICN^MPIFXMLI(.MPIDATA,.PATARR)
+12 ;No ICN returned - keep this record in queue
IF $GET(MPIDATA("ICN"))<1
Begin DoDot:2
+13 SET ^XTMP("MPIF EXPLICIT QUEUE",DFN)=DT_"^"_PATARR("AddType")_"^"_PATARR("mcid")_"^"_$GET(MPIDATA("ERRTXT"))
+14 KILL MPIDATA,PATARR
End DoDot:2
QUIT
+15 ;Store ICN into Patient file
+16 DO VIC40^MPIFAPI(DFN,MPIDATA("ICN"))
+17 ;cleanup the queue
+18 KILL ^XTMP("MPIF EXPLICIT QUEUE",DFN),MPIDATA,PATARR
End DoDot:1
+19 QUIT
GETPAT(DFN,PATARR) ;Get patient data for DFN
+1 NEW NAME,DNM,VAROOT,COUNTRY,STATE,DGDEM,DGOPD,DGADDR,ADDTYP,STOKEN
+2 ; Add type
SET ADDTYP=$PIECE($GET(^XTMP("MPIF EXPLICIT QUEUE",DFN)),"^",2)
+3 ;search token
SET STOKEN=$PIECE($GET(^XTMP("MPIF EXPLICIT QUEUE",DFN)),"^",3)
+4 ;Patient Demographic data
SET VAROOT="DGDEM"
DO DEM^VADPT
+5 ;Patient Other Pertinent Data
SET VAROOT="DGOPD"
DO OPD^VADPT
+6 ;Patient Address data
SET VAROOT="DGADDR"
DO ADD^VADPT
+7 SET PATARR("AddType")=$GET(ADDTYP)
SET PATARR("mcid")=STOKEN
+8 ;NAME
+9 SET DNM=$GET(DGDEM(1))
IF DNM'=""
Begin DoDot:1
+10 DO STDNAME^XLFNAME(.DNM,"C")
+11 SET PATARR(1,"FirstName")=DNM("GIVEN")
SET PATARR(1,"Surname")=DNM("FAMILY")
+12 SET PATARR(1,"MiddleName")=DNM("MIDDLE")
SET PATARR(1,"Suffix")=DNM("SUFFIX")
End DoDot:1
+13 ;SSN
SET PATARR(1,"SSN")=$PIECE($GET(DGDEM(2)),"^")
+14 ;DOB
SET PATARR(1,"DOB")=$PIECE($GET(DGDEM(3)),"^")
+15 ;Gender
SET PATARR(1,"Gender")=$PIECE($GET(DGDEM(5)),"^")
+16 ;Mother's maiden Name
SET PATARR(1,"MMN")=$GET(DGOPD(5))
+17 ;POB City
SET PATARR(1,"POBCity")=$GET(DGOPD(1))
+18 ;POB State
SET PATARR(1,"POBState")=$PIECE($GET(DGOPD(2)),"^")
IF PATARR(1,"POBState")'=""
SET PATARR(1,"POBState")=$PIECE($GET(^DIC(5,PATARR(1,"POBState"),0)),"^",2)
+19 ;Multiple Birth Indicator
SET PATARR(1,"MBI")=$PIECE($GET(^DPT(DFN,"MPIMB")),"^")
+20 ;Date of Death
SET PATARR(1,"DOD")=$PIECE($GET(DGDEM(6)),"^")
+21 ;Address Fields
+22 SET COUNTRY=$PIECE($GET(DGADDR(25)),"^")
+23 IF COUNTRY'=""
IF ($DATA(^HL(779.004,COUNTRY,0)))
Begin DoDot:1
+24 SET PATARR(1,"ResAddL1")=$GET(DGADDR(1))
SET PATARR(1,"ResAddL2")=$GET(DGADDR(2))
+25 SET PATARR(1,"ResAddL3")=$GET(DGADDR(3))
SET PATARR(1,"ResAddCity")=$GET(DGADDR(4))
+26 SET COUNTRY=$PIECE($GET(DGADDR(25)),"^")
SET COUNTRY=$PIECE($GET(^HL(779.004,COUNTRY,0)),"^")
+27 SET PATARR(1,"ResAddCountry")=COUNTRY
+28 IF COUNTRY="USA"
Begin DoDot:2
+29 SET STATE=$PIECE($GET(DGADDR(5)),"^")
IF STATE'=""
SET PATARR(1,"ResAddState")=$PIECE($GET(^DIC(5,STATE,0)),"^",2)
+30 SET PATARR(1,"ResAddZip4")=$GET(DGADDR(6))
End DoDot:2
+31 IF COUNTRY'="USA"
Begin DoDot:2
+32 SET PATARR(1,"ResAddProvince")=$GET(DGADDR(23))
+33 SET PATARR(1,"ResAddPostalCode")=$GET(DGADDR(24))
End DoDot:2
End DoDot:1
+34 ; Phone
+35 SET PATARR(1,"ResPhone")=$GET(DGADDR(8))
+36 ;DFN of Patient
SET PATARR(1,"DFN")=DFN
+37 ;**73, STORY 1218906 (dlr) - Start of Changes
+38 SET PATARR(1,"patientVeteran")=$PIECE($GET(^DPT(DFN,"VET")),"^")
+39 SET PATARR(1,"patientServiceConnected")=$PIECE($GET(^DPT(DFN,.3)),"^")
+40 SET PATARR(1,"patientType")=$$PATTYPE(DFN)
+41 SET PATARR(1,"ICN")=$$GETICN^MPIF001(DFN)
+42 QUIT
PATTYPE(DFN) ;
+1 NEW TYPEIEN,TYPE,RET
+2 SET RET=""
+3 ;
+4 SET TYPEIEN=$PIECE($GET(^DPT(DFN,"TYPE")),"^")
+5 SET TYPE=$PIECE(^DG(391,TYPEIEN,0),"^")
+6 IF TYPE="ACTIVE DUTY"
SET RET=1
+7 IF TYPE="ALLIED VETERAN"
SET RET=2
+8 IF TYPE="COLLATERAL"
SET RET=3
+9 IF TYPE="EMPLOYEE"
SET RET=4
+10 IF TYPE="MILITARY RETIREE"
SET RET=5
+11 IF TYPE="NON-VETERAN (OTHER)"
SET RET=6
+12 IF TYPE="NSC VETERAN"
SET RET=7
+13 IF TYPE="SC VETERAN"
SET RET=8
+14 IF TYPE="TRICARE"
SET RET=9
+15 QUIT RET
+16 ;**73, STORY 1218906 (dlr) - End Changes
