DGRRPSGT ; ALB/SGG - DG R&R PatientServices GET data - return XML ; 09/30/03
;;5.3;Registration;**557**;Aug 13, 1993
;
DOC ;
; ==================================================================
; Documentation for the DGRRPS* routines is in DGRRPSAA.
; ==================================================================
; This routine is called from the RPC DGRR GET PATIENT SERVICES DATA
; ==================================================================
;
;
PATIENT(RESULT,PARAMS) ;
;
NEW CURLINE,ICN,PTID,ERRMESS,PSARRAY,PSGLBCNT,DGRRPS,GLOB,TRACECNT,TRACENO,REQDT
;
DO INITIZE
;Call to INTRACE commented out to prevent to building of the XTMP global.
;DO INTRACE
DO GETPATID(.ICN,.PTID,.ERRMESS) IF $G(ERRMESS)'="" GOTO ERROR
S REQDT=$G(PARAMS("REQUESTED_DATE"))
DO GETGLOBS
;
BUILD ; BUILD THE PATIENT XML
SET PSARRAY(1)=$$XMLHDR^DGRR557U_"^^^1" DO APPEND(.PSARRAY)
SET PSARRAY(1)="<Patient>" DO APPEND(.PSARRAY)
DO GETPSARY^DGRRPSID(.PSARRAY) DO APPEND(.PSARRAY)
IF +$G(PARAMS("PrimaryDemo")) DO GETPSARY^DGRRPSD1(.PSARRAY) DO APPEND(.PSARRAY)
IF +$G(PARAMS("SecondaryDemo")) DO GETPSARY^DGRRPSD2(.PSARRAY) DO APPEND(.PSARRAY)
IF +$G(PARAMS("TertiaryDemo")) DO GETPSARY^DGRRPSD3(.PSARRAY) DO APPEND(.PSARRAY)
IF +$G(PARAMS("MainAddress")) DO GETPSARY^DGRRPSAM(.PSARRAY) DO APPEND(.PSARRAY)
IF +$G(PARAMS("TemporaryAddress")) DO GETPSARY^DGRRPSAT(.PSARRAY) DO APPEND(.PSARRAY)
IF +$G(PARAMS("ConfidentialAddress")) DO GETPSARY^DGRRPSAC(.PSARRAY) DO APPEND(.PSARRAY)
IF +$G(PARAMS("ContactInfo")) DO GETPSARY^DGRRPSKN(.PSARRAY) DO APPEND(.PSARRAY)
IF +$G(PARAMS("ADTInfo")) DO GETPSARY^DGRRPSAD(.PSARRAY,REQDT) DO APPEND(.PSARRAY)
IF +$G(PARAMS("EnrollEligibility")) DO GETPSARY^DGRRPSEE(.PSARRAY) DO APPEND(.PSARRAY)
IF +$G(PARAMS("Incompetent")) DO GETPSARY^DGRRPSIC(.PSARRAY) DO APPEND(.PSARRAY)
DO GETPSARY^DGRRPSIN(.PSARRAY) DO APPEND(.PSARRAY)
SET PSARRAY(1)="<Error Message=''></Error>" DO APPEND(.PSARRAY)
SET PSARRAY(1)="</Patient>"_"^^^1" DO APPEND(.PSARRAY)
;Call to OUTTRACE commented out preventing the building/purging of the
;XTMP global.
;DO OUTTRACE
EXIT QUIT
;
APPEND(PSARRAY) ;
; Append PSARRAY(1...n)= TextOnly ^ XML_attribute ^ ValueOfAttribute ^ FileNowFlag
; In some code there are 5th and 6th pieces to this,, they are not used,, it was the start of a receiver/parser that was never needed
NEW MAXGL,TEXT,ATTRIB,VALUE,CLOSEOUT,NEWLINE
SET MAXGL=240 ; maximum global length
SET PSARRAY="" FOR SET PSARRAY=$O(PSARRAY(PSARRAY)) QUIT:PSARRAY="" DO
.SET TEXT=$P(PSARRAY(PSARRAY),"^",1)
.SET ATTRIB=$P(PSARRAY(PSARRAY),"^",2)
.SET VALUE=$P(PSARRAY(PSARRAY),"^",3)
.SET CLOSEOUT=$P(PSARRAY(PSARRAY),"^",4)
.SET CURLINE=$G(CURLINE)
.SET NEWLINE=TEXT
.IF ATTRIB'="" SET NEWLINE=NEWLINE_" "_ATTRIB_"='"_$S(VALUE'="":$$CHARCHK^DGRR557U(VALUE),1:"")_"'"
.IF ($L(CURLINE)+$L(NEWLINE))>MAXGL DO
..SET ^TMP($J,"PS-DATA",PSGLBCNT)=$E(CURLINE_NEWLINE,1,MAXGL)
..SET PSGLBCNT=PSGLBCNT+1
..SET CURLINE=$E(CURLINE_NEWLINE,MAXGL+1,999),NEWLINE=""
.SET CURLINE=CURLINE_NEWLINE
.IF +$G(CLOSEOUT),+$L(CURLINE) DO
..SET ^TMP($J,"PS-DATA",PSGLBCNT)=CURLINE
..SET PSGLBCNT=PSGLBCNT+1
..SET CURLINE=""
.QUIT
KILL PSARRAY
QUIT
;
INITIZE ; Initialize variables
KILL RESULT
KILL ^TMP($J,"PS-DATA")
SET PSGLBCNT=1
SET DGRRPS="^TMP($J,""PS-DATA"")"
SET RESULT=$NA(@DGRRPS)
IF '$D(DT) D DTNOLF^DICRW
KILL PSARRAY
QUIT
;
INTRACE ; Keep a record of what has been requested
N PURGDT
S PURGDT=$$FMADD^XLFDT(DT,31)
IF '$D(^XTMP("DGRRPS",0)) SET ^XTMP("DGRRPS",0)=PURGDT_"^"_DT_"^"_"LAST 30 DAYS OF PATIENT SERVICES ACTIVITY - CREATED IN RTN DGRRPSGT - THIS GLOBAL IS SELF PURGING ON >10,000 RECORDS OR >31 DAYS - email:VHA OI SDD CS Person Demographic"
SET $P(^XTMP("DGRRPS",0),"^",1)=PURGDT
SET TRACECNT=$G(^XTMP("DGRRPS","COUNT"))+1,^XTMP("DGRRPS","COUNT")=TRACECNT
SET ^XTMP("DGRRPS","TRACE",TRACECNT,"DATE",DT)=$$NOW^XLFDT
MERGE ^XTMP("DGRRPS","TRACE",TRACECNT,"PARAMS")=PARAMS
QUIT
;
GETPATID(ICN,PTID,ERRMESS) ; Get patient PTID and ICN
IF $G(PARAMS("PatientId_Type"))="ICN" DO
.SET ICN=$G(PARAMS("PatientId"))
.IF $E(ICN,1,6)=" ICN: " SET ICN=$E(ICN,7,99)
.SET ICN=$P(ICN,"^",1)
.SET PTID=$$GETDFN^MPIF001(ICN)
.; Call MPI API to be sure ICN is returned in ICN_V_checksum format
.SET ICN=$$GETICN^MPIF001(PTID)
.IF $G(PTID)<1 SET ERRMESS=$P(PTID,"^",2)
IF $G(PARAMS("PatientId_Type"))="DFN" DO
.SET PTID=+$G(PARAMS("PatientId"))
.SET ICN=$$GETICN^MPIF001(PTID)
.;IF +ICN<1 SET ERRMESS=$P(ICN,"^",2)
.IF ICN<1 SET ICN=""
IF ($G(PARAMS("PatientId_Type"))'="DFN"),($G(PARAMS("PatientId_Type"))'="ICN") SET ERRMESS="Unknown PatientId_Type"
QUIT
;
GETGLOBS ; Get required DPT globals
SET GLOB(0)=$G(^DPT(PTID,0))
SET GLOB(.11)=$G(^DPT(PTID,.11))
SET GLOB(.121)=$G(^DPT(PTID,.121))
SET GLOB(.13)=$G(^DPT(PTID,.13))
KILL GLOB(.14) MERGE GLOB(.14)=^DPT(PTID,.14)
SET GLOB(.141)=$G(^DPT(PTID,.141))
SET GLOB(.15)=$G(^DPT(PTID,.15))
SET GLOB(.22)=$G(^DPT(PTID,.22))
SET GLOB(.24)=$G(^DPT(PTID,.24))
SET GLOB(.29)=$G(^DPT(PTID,.29))
SET GLOB(.291)=$G(^DPT(PTID,.291))
SET GLOB(.3)=$G(^DPT(PTID,.3))
SET GLOB(.31)=$G(^DPT(PTID,.31))
SET GLOB(.32)=$G(^DPT(PTID,.32))
SET GLOB(.35)=$G(^DPT(PTID,.35))
SET GLOB(.36)=$G(^DPT(PTID,.36))
SET GLOB(.361)=$G(^DPT(PTID,.361))
SET GLOB(38.1)=$G(^DGSL(38.1,PTID,0))
SET GLOB(57)=$G(^DPT(PTID,57))
SET GLOB("NAME")=$$GETNME(PTID)
QUIT
;
GETNME(PTID) ; return patient name components
NEW RE,DGRRN
S DGRRN("FILE")=2
S DGRRN("FIELD")=.01
S DGRRN("IENS")=$$IENS^DILF(+PTID)
S RE=$$HLNAME^XLFNAME(.DGRRN)
Q RE
;
OUTTRACE ; Keep a record of what has been put out
MERGE ^XTMP("DGRRPS","TRACE",+$G(TRACECNT),"DATA")=^TMP($J,"PS-DATA")
PURGE ; Purge trace > 31 days and >10,000 records
SET TRACENO="" FOR SET TRACENO=$O(^XTMP("DGRRPS","TRACE",TRACENO)) QUIT:TRACENO="" QUIT:($O(^XTMP("DGRRPS","TRACE",TRACENO,"DATE",""))>($$FMADD^XLFDT(DT,-31))) KILL ^XTMP("DGRRPS","TRACE",TRACENO)
SET TRACENO="" FOR SET TRACENO=$O(^XTMP("DGRRPS","TRACE",TRACENO)) QUIT:TRACENO="" QUIT:(TRACENO>($O(^XTMP("DGRRPS","TRACE",""),-1)-10000)) KILL ^XTMP("DGRRPS","TRACE",TRACENO)
QUIT
;
ERROR ; Build an Error XML and quit
DO INITIZE
SET PSARRAY(1)=$$XMLHDR^DGRR557U_"^^^1"
SET PSARRAY(2)="<Patient>"_"^^^1"
SET PSARRAY(3)="<Error"
SET PSARRAY(4)="^Message^"_ERRMESS
SET PSARRAY(5)="^PatientId^"_$G(PARAMS("PatientId"))
SET PSARRAY(6)="></Error>"_"^^^1"
SET PSARRAY(7)="</Patient>"_"^^^1" DO APPEND(.PSARRAY)
;DO OUTTRACE
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRRPSGT 6635 printed Sep 23, 2025@20:33:45 Page 2
DGRRPSGT ; ALB/SGG - DG R&R PatientServices GET data - return XML ; 09/30/03
+1 ;;5.3;Registration;**557**;Aug 13, 1993
+2 ;
DOC ;
+1 ; ==================================================================
+2 ; Documentation for the DGRRPS* routines is in DGRRPSAA.
+3 ; ==================================================================
+4 ; This routine is called from the RPC DGRR GET PATIENT SERVICES DATA
+5 ; ==================================================================
+6 ;
+7 ;
PATIENT(RESULT,PARAMS) ;
+1 ;
+2 NEW CURLINE,ICN,PTID,ERRMESS,PSARRAY,PSGLBCNT,DGRRPS,GLOB,TRACECNT,TRACENO,REQDT
+3 ;
+4 DO INITIZE
+5 ;Call to INTRACE commented out to prevent to building of the XTMP global.
+6 ;DO INTRACE
+7 DO GETPATID(.ICN,.PTID,.ERRMESS)
IF $GET(ERRMESS)'=""
GOTO ERROR
+8 SET REQDT=$GET(PARAMS("REQUESTED_DATE"))
+9 DO GETGLOBS
+10 ;
BUILD ; BUILD THE PATIENT XML
+1 SET PSARRAY(1)=$$XMLHDR^DGRR557U_"^^^1"
DO APPEND(.PSARRAY)
+2 SET PSARRAY(1)="<Patient>"
DO APPEND(.PSARRAY)
+3 DO GETPSARY^DGRRPSID(.PSARRAY)
DO APPEND(.PSARRAY)
+4 IF +$GET(PARAMS("PrimaryDemo"))
DO GETPSARY^DGRRPSD1(.PSARRAY)
DO APPEND(.PSARRAY)
+5 IF +$GET(PARAMS("SecondaryDemo"))
DO GETPSARY^DGRRPSD2(.PSARRAY)
DO APPEND(.PSARRAY)
+6 IF +$GET(PARAMS("TertiaryDemo"))
DO GETPSARY^DGRRPSD3(.PSARRAY)
DO APPEND(.PSARRAY)
+7 IF +$GET(PARAMS("MainAddress"))
DO GETPSARY^DGRRPSAM(.PSARRAY)
DO APPEND(.PSARRAY)
+8 IF +$GET(PARAMS("TemporaryAddress"))
DO GETPSARY^DGRRPSAT(.PSARRAY)
DO APPEND(.PSARRAY)
+9 IF +$GET(PARAMS("ConfidentialAddress"))
DO GETPSARY^DGRRPSAC(.PSARRAY)
DO APPEND(.PSARRAY)
+10 IF +$GET(PARAMS("ContactInfo"))
DO GETPSARY^DGRRPSKN(.PSARRAY)
DO APPEND(.PSARRAY)
+11 IF +$GET(PARAMS("ADTInfo"))
DO GETPSARY^DGRRPSAD(.PSARRAY,REQDT)
DO APPEND(.PSARRAY)
+12 IF +$GET(PARAMS("EnrollEligibility"))
DO GETPSARY^DGRRPSEE(.PSARRAY)
DO APPEND(.PSARRAY)
+13 IF +$GET(PARAMS("Incompetent"))
DO GETPSARY^DGRRPSIC(.PSARRAY)
DO APPEND(.PSARRAY)
+14 DO GETPSARY^DGRRPSIN(.PSARRAY)
DO APPEND(.PSARRAY)
+15 SET PSARRAY(1)="<Error Message=''></Error>"
DO APPEND(.PSARRAY)
+16 SET PSARRAY(1)="</Patient>"_"^^^1"
DO APPEND(.PSARRAY)
+17 ;Call to OUTTRACE commented out preventing the building/purging of the
+18 ;XTMP global.
+19 ;DO OUTTRACE
EXIT QUIT
+1 ;
APPEND(PSARRAY) ;
+1 ; Append PSARRAY(1...n)= TextOnly ^ XML_attribute ^ ValueOfAttribute ^ FileNowFlag
+2 ; In some code there are 5th and 6th pieces to this,, they are not used,, it was the start of a receiver/parser that was never needed
+3 NEW MAXGL,TEXT,ATTRIB,VALUE,CLOSEOUT,NEWLINE
+4 ; maximum global length
SET MAXGL=240
+5 SET PSARRAY=""
FOR
SET PSARRAY=$ORDER(PSARRAY(PSARRAY))
if PSARRAY=""
QUIT
Begin DoDot:1
+6 SET TEXT=$PIECE(PSARRAY(PSARRAY),"^",1)
+7 SET ATTRIB=$PIECE(PSARRAY(PSARRAY),"^",2)
+8 SET VALUE=$PIECE(PSARRAY(PSARRAY),"^",3)
+9 SET CLOSEOUT=$PIECE(PSARRAY(PSARRAY),"^",4)
+10 SET CURLINE=$GET(CURLINE)
+11 SET NEWLINE=TEXT
+12 IF ATTRIB'=""
SET NEWLINE=NEWLINE_" "_ATTRIB_"='"_$SELECT(VALUE'="":$$CHARCHK^DGRR557U(VALUE),1:"")_"'"
+13 IF ($LENGTH(CURLINE)+$LENGTH(NEWLINE))>MAXGL
Begin DoDot:2
+14 SET ^TMP($JOB,"PS-DATA",PSGLBCNT)=$EXTRACT(CURLINE_NEWLINE,1,MAXGL)
+15 SET PSGLBCNT=PSGLBCNT+1
+16 SET CURLINE=$EXTRACT(CURLINE_NEWLINE,MAXGL+1,999)
SET NEWLINE=""
End DoDot:2
+17 SET CURLINE=CURLINE_NEWLINE
+18 IF +$GET(CLOSEOUT)
IF +$LENGTH(CURLINE)
Begin DoDot:2
+19 SET ^TMP($JOB,"PS-DATA",PSGLBCNT)=CURLINE
+20 SET PSGLBCNT=PSGLBCNT+1
+21 SET CURLINE=""
End DoDot:2
+22 QUIT
End DoDot:1
+23 KILL PSARRAY
+24 QUIT
+25 ;
INITIZE ; Initialize variables
+1 KILL RESULT
+2 KILL ^TMP($JOB,"PS-DATA")
+3 SET PSGLBCNT=1
+4 SET DGRRPS="^TMP($J,""PS-DATA"")"
+5 SET RESULT=$NAME(@DGRRPS)
+6 IF '$DATA(DT)
DO DTNOLF^DICRW
+7 KILL PSARRAY
+8 QUIT
+9 ;
INTRACE ; Keep a record of what has been requested
+1 NEW PURGDT
+2 SET PURGDT=$$FMADD^XLFDT(DT,31)
+3 IF '$DATA(^XTMP("DGRRPS",0))
SET ^XTMP("DGRRPS",0)=PURGDT_"^"_DT_"^"_"LAST 30 DAYS OF PATIENT SERVICES ACTIVITY - CREATED IN RTN DGRRPSGT - THIS GLOBAL IS SELF PURGING ON >10,000 RECORDS OR >31 DAYS - email:VHA OI SDD CS Person Demographic"
+4 SET $PIECE(^XTMP("DGRRPS",0),"^",1)=PURGDT
+5 SET TRACECNT=$GET(^XTMP("DGRRPS","COUNT"))+1
SET ^XTMP("DGRRPS","COUNT")=TRACECNT
+6 SET ^XTMP("DGRRPS","TRACE",TRACECNT,"DATE",DT)=$$NOW^XLFDT
+7 MERGE ^XTMP("DGRRPS","TRACE",TRACECNT,"PARAMS")=PARAMS
+8 QUIT
+9 ;
GETPATID(ICN,PTID,ERRMESS) ; Get patient PTID and ICN
+1 IF $GET(PARAMS("PatientId_Type"))="ICN"
Begin DoDot:1
+2 SET ICN=$GET(PARAMS("PatientId"))
+3 IF $EXTRACT(ICN,1,6)=" ICN: "
SET ICN=$EXTRACT(ICN,7,99)
+4 SET ICN=$PIECE(ICN,"^",1)
+5 SET PTID=$$GETDFN^MPIF001(ICN)
+6 ; Call MPI API to be sure ICN is returned in ICN_V_checksum format
+7 SET ICN=$$GETICN^MPIF001(PTID)
+8 IF $GET(PTID)<1
SET ERRMESS=$PIECE(PTID,"^",2)
End DoDot:1
+9 IF $GET(PARAMS("PatientId_Type"))="DFN"
Begin DoDot:1
+10 SET PTID=+$GET(PARAMS("PatientId"))
+11 SET ICN=$$GETICN^MPIF001(PTID)
+12 ;IF +ICN<1 SET ERRMESS=$P(ICN,"^",2)
+13 IF ICN<1
SET ICN=""
End DoDot:1
+14 IF ($GET(PARAMS("PatientId_Type"))'="DFN")
IF ($GET(PARAMS("PatientId_Type"))'="ICN")
SET ERRMESS="Unknown PatientId_Type"
+15 QUIT
+16 ;
GETGLOBS ; Get required DPT globals
+1 SET GLOB(0)=$GET(^DPT(PTID,0))
+2 SET GLOB(.11)=$GET(^DPT(PTID,.11))
+3 SET GLOB(.121)=$GET(^DPT(PTID,.121))
+4 SET GLOB(.13)=$GET(^DPT(PTID,.13))
+5 KILL GLOB(.14)
MERGE GLOB(.14)=^DPT(PTID,.14)
+6 SET GLOB(.141)=$GET(^DPT(PTID,.141))
+7 SET GLOB(.15)=$GET(^DPT(PTID,.15))
+8 SET GLOB(.22)=$GET(^DPT(PTID,.22))
+9 SET GLOB(.24)=$GET(^DPT(PTID,.24))
+10 SET GLOB(.29)=$GET(^DPT(PTID,.29))
+11 SET GLOB(.291)=$GET(^DPT(PTID,.291))
+12 SET GLOB(.3)=$GET(^DPT(PTID,.3))
+13 SET GLOB(.31)=$GET(^DPT(PTID,.31))
+14 SET GLOB(.32)=$GET(^DPT(PTID,.32))
+15 SET GLOB(.35)=$GET(^DPT(PTID,.35))
+16 SET GLOB(.36)=$GET(^DPT(PTID,.36))
+17 SET GLOB(.361)=$GET(^DPT(PTID,.361))
+18 SET GLOB(38.1)=$GET(^DGSL(38.1,PTID,0))
+19 SET GLOB(57)=$GET(^DPT(PTID,57))
+20 SET GLOB("NAME")=$$GETNME(PTID)
+21 QUIT
+22 ;
GETNME(PTID) ; return patient name components
+1 NEW RE,DGRRN
+2 SET DGRRN("FILE")=2
+3 SET DGRRN("FIELD")=.01
+4 SET DGRRN("IENS")=$$IENS^DILF(+PTID)
+5 SET RE=$$HLNAME^XLFNAME(.DGRRN)
+6 QUIT RE
+7 ;
OUTTRACE ; Keep a record of what has been put out
+1 MERGE ^XTMP("DGRRPS","TRACE",+$GET(TRACECNT),"DATA")=^TMP($JOB,"PS-DATA")
PURGE ; Purge trace > 31 days and >10,000 records
+1 SET TRACENO=""
FOR
SET TRACENO=$ORDER(^XTMP("DGRRPS","TRACE",TRACENO))
if TRACENO=""
QUIT
if ($ORDER(^XTMP("DGRRPS","TRACE",TRACENO,"DATE",""))>($$FMADD^XLFDT(DT,-31)))
QUIT
KILL ^XTMP("DGRRPS","TRACE",TRACENO)
+2 SET TRACENO=""
FOR
SET TRACENO=$ORDER(^XTMP("DGRRPS","TRACE",TRACENO))
if TRACENO=""
QUIT
if (TRACENO>($ORDER(^XTMP("DGRRPS","TRACE",""),-1)-10000))
QUIT
KILL ^XTMP("DGRRPS","TRACE",TRACENO)
+3 QUIT
+4 ;
ERROR ; Build an Error XML and quit
+1 DO INITIZE
+2 SET PSARRAY(1)=$$XMLHDR^DGRR557U_"^^^1"
+3 SET PSARRAY(2)="<Patient>"_"^^^1"
+4 SET PSARRAY(3)="<Error"
+5 SET PSARRAY(4)="^Message^"_ERRMESS
+6 SET PSARRAY(5)="^PatientId^"_$GET(PARAMS("PatientId"))
+7 SET PSARRAY(6)="></Error>"_"^^^1"
+8 SET PSARRAY(7)="</Patient>"_"^^^1"
DO APPEND(.PSARRAY)
+9 ;DO OUTTRACE
+10 QUIT
