Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGRRPSGT

DGRRPSGT.m

Go to the documentation of this file. 
  1. DGRRPSGT ; ALB/SGG - DG R&R PatientServices GET data - return XML ; 09/30/03
  1.  ;;5.3;Registration;**557,1015**;Aug 13, 1993;Build 21
  1.  ;
  1. DOC ;
  1.  ; ==================================================================
  1.  ;      Documentation for the DGRRPS* routines is in DGRRPSAA.
  1.  ; ==================================================================
  1.  ; This routine is called from the RPC DGRR GET PATIENT SERVICES DATA
  1.  ; ==================================================================
  1.  ;
  1.  ;
  1. PATIENT(RESULT,PARAMS) ;
  1.  ;
  1.  NEW CURLINE,ICN,PTID,ERRMESS,PSARRAY,PSGLBCNT,DGRRPS,GLOB,TRACECNT,TRACENO,REQDT
  1.  ;
  1.  DO INITIZE
  1.  ;Call to INTRACE commented out to prevent to building of the XTMP global.
  1.  ;DO INTRACE
  1.  DO GETPATID(.ICN,.PTID,.ERRMESS) IF $G(ERRMESS)'="" GOTO ERROR
  1.  S REQDT=$G(PARAMS("REQUESTED_DATE"))
  1.  DO GETGLOBS
  1.  ;
  1. BUILD ; BUILD THE PATIENT XML
  1.  SET PSARRAY(1)=$$XMLHDR^DGRR557U_"^^^1" DO APPEND(.PSARRAY)
  1.  SET PSARRAY(1)="<Patient>" DO APPEND(.PSARRAY)
  1.  DO GETPSARY^DGRRPSID(.PSARRAY) DO APPEND(.PSARRAY)
  1.  IF +$G(PARAMS("PrimaryDemo")) DO GETPSARY^DGRRPSD1(.PSARRAY) DO APPEND(.PSARRAY)
  1.  IF +$G(PARAMS("SecondaryDemo")) DO GETPSARY^DGRRPSD2(.PSARRAY) DO APPEND(.PSARRAY)
  1.  IF +$G(PARAMS("TertiaryDemo")) DO GETPSARY^DGRRPSD3(.PSARRAY) DO APPEND(.PSARRAY)
  1.  IF +$G(PARAMS("MainAddress")) DO GETPSARY^DGRRPSAM(.PSARRAY) DO APPEND(.PSARRAY)
  1.  IF +$G(PARAMS("TemporaryAddress")) DO GETPSARY^DGRRPSAT(.PSARRAY) DO APPEND(.PSARRAY)
  1.  IF +$G(PARAMS("ConfidentialAddress")) DO GETPSARY^DGRRPSAC(.PSARRAY) DO APPEND(.PSARRAY)
  1.  IF +$G(PARAMS("ContactInfo")) DO GETPSARY^DGRRPSKN(.PSARRAY) DO APPEND(.PSARRAY)
  1.  IF +$G(PARAMS("ADTInfo")) DO GETPSARY^DGRRPSAD(.PSARRAY,REQDT) DO APPEND(.PSARRAY)
  1.  IF +$G(PARAMS("EnrollEligibility")) DO GETPSARY^DGRRPSEE(.PSARRAY) DO APPEND(.PSARRAY)
  1.  IF +$G(PARAMS("Incompetent")) DO GETPSARY^DGRRPSIC(.PSARRAY) DO APPEND(.PSARRAY)
  1.  DO GETPSARY^DGRRPSIN(.PSARRAY) DO APPEND(.PSARRAY)
  1.  SET PSARRAY(1)="<Error Message=''></Error>" DO APPEND(.PSARRAY)
  1.  SET PSARRAY(1)="</Patient>"_"^^^1" DO APPEND(.PSARRAY)
  1.  ;Call to OUTTRACE commented out preventing the building/purging of the
  1.  ;XTMP global.
  1.  ;DO OUTTRACE
  1. EXIT QUIT
  1.  ;
  1. APPEND(PSARRAY) ; 
  1.  ; Append PSARRAY(1...n)= TextOnly ^ XML_attribute ^ ValueOfAttribute ^ FileNowFlag
  1.  ; 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
  1.  NEW MAXGL,TEXT,ATTRIB,VALUE,CLOSEOUT,NEWLINE
  1.  SET MAXGL=240 ; maximum global length
  1.  SET PSARRAY="" FOR  SET PSARRAY=$O(PSARRAY(PSARRAY)) QUIT:PSARRAY=""  DO
  1.  .SET TEXT=$P(PSARRAY(PSARRAY),"^",1)
  1.  .SET ATTRIB=$P(PSARRAY(PSARRAY),"^",2)
  1.  .SET VALUE=$P(PSARRAY(PSARRAY),"^",3)
  1.  .SET CLOSEOUT=$P(PSARRAY(PSARRAY),"^",4)
  1.  .SET CURLINE=$G(CURLINE)
  1.  .SET NEWLINE=TEXT
  1.  .IF ATTRIB'="" SET NEWLINE=NEWLINE_" "_ATTRIB_"='"_$S(VALUE'="":$$CHARCHK^DGRR557U(VALUE),1:"")_"'"
  1.  .IF ($L(CURLINE)+$L(NEWLINE))>MAXGL DO
  1.  ..SET ^TMP($J,"PS-DATA",PSGLBCNT)=$E(CURLINE_NEWLINE,1,MAXGL)
  1.  ..SET PSGLBCNT=PSGLBCNT+1
  1.  ..SET CURLINE=$E(CURLINE_NEWLINE,MAXGL+1,999),NEWLINE=""
  1.  .SET CURLINE=CURLINE_NEWLINE
  1.  .IF +$G(CLOSEOUT),+$L(CURLINE) DO
  1.  ..SET ^TMP($J,"PS-DATA",PSGLBCNT)=CURLINE
  1.  ..SET PSGLBCNT=PSGLBCNT+1
  1.  ..SET CURLINE=""
  1.  .QUIT
  1.  KILL PSARRAY
  1.  QUIT
  1.  ;
  1. INITIZE ; Initialize variables
  1.  KILL RESULT
  1.  KILL ^TMP($J,"PS-DATA")
  1.  SET PSGLBCNT=1
  1.  SET DGRRPS="^TMP($J,""PS-DATA"")"
  1.  SET RESULT=$NA(@DGRRPS)
  1.  IF '$D(DT) D DTNOLF^DICRW
  1.  KILL PSARRAY
  1.  QUIT
  1.  ;
  1. INTRACE ; Keep a record of what has been requested
  1.  N PURGDT
  1.  S PURGDT=$$FMADD^XLFDT(DT,31)
  1.  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"
  1.  SET $P(^XTMP("DGRRPS",0),"^",1)=PURGDT
  1.  SET TRACECNT=$G(^XTMP("DGRRPS","COUNT"))+1,^XTMP("DGRRPS","COUNT")=TRACECNT
  1.  SET ^XTMP("DGRRPS","TRACE",TRACECNT,"DATE",DT)=$$NOW^XLFDT
  1.  MERGE ^XTMP("DGRRPS","TRACE",TRACECNT,"PARAMS")=PARAMS
  1.  QUIT
  1.  ;
  1. GETPATID(ICN,PTID,ERRMESS) ; Get patient PTID and ICN
  1.  IF $G(PARAMS("PatientId_Type"))="ICN" DO
  1.  .SET ICN=$G(PARAMS("PatientId"))
  1.  .IF $E(ICN,1,6)=" ICN: " SET ICN=$E(ICN,7,99)
  1.  .SET ICN=$P(ICN,"^",1)
  1.  .SET PTID=$$GETDFN^MPIF001(ICN)
  1.  .; Call MPI API to be sure ICN is returned in ICN_V_checksum format
  1.  .SET ICN=$$GETICN^MPIF001(PTID)
  1.  .IF $G(PTID)<1 SET ERRMESS=$P(PTID,"^",2)
  1.  IF $G(PARAMS("PatientId_Type"))="DFN" DO
  1.  .SET PTID=+$G(PARAMS("PatientId"))
  1.  .SET ICN=$$GETICN^MPIF001(PTID)
  1.  .;IF +ICN<1 SET ERRMESS=$P(ICN,"^",2)
  1.  .IF ICN<1 SET ICN=""
  1.  IF ($G(PARAMS("PatientId_Type"))'="DFN"),($G(PARAMS("PatientId_Type"))'="ICN") SET ERRMESS="Unknown PatientId_Type"
  1.  QUIT
  1.  ;
  1. GETGLOBS ; Get required DPT globals
  1.  SET GLOB(0)=$G(^DPT(PTID,0))
  1.  SET GLOB(.11)=$G(^DPT(PTID,.11))
  1.  SET GLOB(.121)=$G(^DPT(PTID,.121))
  1.  SET GLOB(.13)=$G(^DPT(PTID,.13))
  1.  KILL GLOB(.14) MERGE GLOB(.14)=^DPT(PTID,.14)
  1.  SET GLOB(.141)=$G(^DPT(PTID,.141))
  1.  SET GLOB(.15)=$G(^DPT(PTID,.15))
  1.  SET GLOB(.22)=$G(^DPT(PTID,.22))
  1.  SET GLOB(.24)=$G(^DPT(PTID,.24))
  1.  SET GLOB(.29)=$G(^DPT(PTID,.29))
  1.  SET GLOB(.291)=$G(^DPT(PTID,.291))
  1.  SET GLOB(.3)=$G(^DPT(PTID,.3))
  1.  SET GLOB(.31)=$G(^DPT(PTID,.31))
  1.  SET GLOB(.32)=$G(^DPT(PTID,.32))
  1.  SET GLOB(.35)=$G(^DPT(PTID,.35))
  1.  SET GLOB(.36)=$G(^DPT(PTID,.36))
  1.  SET GLOB(.361)=$G(^DPT(PTID,.361))
  1.  SET GLOB(38.1)=$G(^DGSL(38.1,PTID,0))
  1.  SET GLOB(57)=$G(^DPT(PTID,57))
  1.  SET GLOB("NAME")=$$GETNME(PTID)
  1.  QUIT
  1.  ;
  1. GETNME(PTID) ; return patient name components
  1.  NEW RE,DGRRN
  1.  S DGRRN("FILE")=2
  1.  S DGRRN("FIELD")=.01
  1.  S DGRRN("IENS")=$$IENS^DILF(+PTID)
  1.  S RE=$$HLNAME^XLFNAME(.DGRRN)
  1.  Q RE
  1.  ;
  1. OUTTRACE ; Keep a record of what has been put out
  1.  MERGE ^XTMP("DGRRPS","TRACE",+$G(TRACECNT),"DATA")=^TMP($J,"PS-DATA")
  1. PURGE ; Purge trace > 31 days and >10,000 records
  1.  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)
  1.  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)
  1.  QUIT
  1.  ;
  1. ERROR ; Build an Error XML and quit
  1.  DO INITIZE
  1.  SET PSARRAY(1)=$$XMLHDR^DGRR557U_"^^^1"
  1.  SET PSARRAY(2)="<Patient>"_"^^^1"
  1.  SET PSARRAY(3)="<Error"
  1.  SET PSARRAY(4)="^Message^"_ERRMESS
  1.  SET PSARRAY(5)="^PatientId^"_$G(PARAMS("PatientId"))
  1.  SET PSARRAY(6)="></Error>"_"^^^1"
  1.  SET PSARRAY(7)="</Patient>"_"^^^1" DO APPEND(.PSARRAY)
  1.  ;DO OUTTRACE
  1.  QUIT