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

DGRRLU.m

Go to the documentation of this file.
  1. DGRRLU ;alb/aas - DG Replacement and Rehosting RPC for VADPT ;12/22/05 14:53
  1. ;;5.3;Registration;**538**;Aug 13, 1993
  1. ;
  1. SET X="You Can't Enter DGRRLU at top of routine!"
  1. QUIT
  1. ;
  1. ; -- RPC: DGRR PATIENT LOOKUP SEARCH
  1. ;
  1. ; -- input PARAMS ARRAY
  1. ; PARAMS("SEARCH_TYPE") = "NAME","SSN","ICN","SSN4","DFN", "PRVLUP"
  1. ; PARAMS("SEARCH_VALUE") = value to search for.
  1. ; PARAMS("JOB") = a unique job # used to check for cancelled jobs
  1. ;
  1. NEW I,X,Y,DGRRAPTS,DGRRIENS,DGRRPCNT,DGRRLINE,DGRRLIST,DGRRESLT,SEARCH,VALUE,FILTER,FILTERV,BDATE,EDATE,CODE,CANCEL,JOB ; ****
  1. NEW MAXSIZE,MAXSIZRE,LINENO,DELIM,DOMAIN,RESTRICT,ERRMSG,SITENM,SITENO,PRODSTAT,DGERR
  1. ; NEW MSCREEN ; references to MSCREEN removed by sgg 05/06/04 advised by babul no longer required
  1. IF '$D(DT) D DT^DICRW
  1. KILL RESULT
  1. SET DGRRPCNT=0
  1. SET DGRRLINE=0
  1. K ^TMP($J,"PLU-SEARCH")
  1. SET DGRRESLT="^TMP($J,""PLU-SEARCH"")"
  1. SET RESULT=$NA(@DGRRESLT)
  1. DO ADD($$XMLHDR^DGRRUTL)
  1. ;
  1. SET CANCEL=0 ; ****
  1. SET SEARCH=$$UP^XLFSTR($GET(PARAMS("SEARCH_TYPE")))
  1. SET VALUE=$$UP^XLFSTR($GET(PARAMS("SEARCH_VALUE")))
  1. SET MAXSIZE=+$GET(PARAMS("MAX_PATIENTS"),50),MAXSIZRE=0
  1. ;
  1. IF (MAXSIZE<5) SET MAXSIZE=5
  1. IF (MAXSIZE>100) SET MAXSIZE=100
  1. ;
  1. SET FILTER=$$UP^XLFSTR($GET(PARAMS("FILTER_TYPE")))
  1. SET FILTERV=$G(PARAMS("FILTER_VALUE"))
  1. SET BDATE=$G(PARAMS("CLINIC_STARTDATE"))
  1. SET EDATE=$G(PARAMS("CLINIC_ENDDATE"))
  1. SET JOB=$G(PARAMS("JOB")) ; ****
  1. I JOB="" S JOB=0 ; **** Until Job parameter is used
  1. ;SET MSCREEN=$$UP^XLFSTR($G(PARAMS("MSCREEN")))
  1. ;IF MSCREEN'="" DO
  1. ;. SET X=MSCREEN D ^DIM IF $D(X)=0 SET MSCREEN="" SET ERRMSG="MSCREEN is invalid M code" Q
  1. ;. IF $E(MSCREEN)'="I" SET MSCREEN="" SET ERRMSG="MSCREEN Deleted, must start with an If statement." Q
  1. ;. IF MSCREEN[" S "!(MSCREEN[" SET ")!(MSCREEN[" S:")!(MSCREEN["SET:") SET MSCREEN="" SET ERRMSG="MSCREEN Deleted, can not set values." Q
  1. ;. IF MSCREEN[" K "!(MSCREEN[" KILL ")!(MSCREEN[" K:")!(MSCREEN["SET:") SET MSCREEN="" SET ERRMSG="MSCREEN Deleted, can not kill values." Q
  1. ;. IF MSCREEN[" W "!(MSCREEN[" WRITE ")!(MSCREEN[" W:")!(MSCREEN["WRITE:") SET MSCREEN="" SET ERRMSG="MSCREEN Deleted, can not WRITE." Q
  1. SET DELIM=$G(PARAMS("DELIMITER"),",") ; Defaults to comma to support old way.
  1. ;
  1. SET SITENM=$$CHARCHK^DGRRUTL($$SITENAM^DGRRUTL())
  1. SET SITENO=$$CHARCHK^DGRRUTL($$SITENO^DGRRUTL())
  1. SET X=$$PRODST1^DGRRUTL()
  1. SET Y=$$PRODST2^DGRRUTL()
  1. SET PRODSTAT=$$CHARCHK^DGRRUTL(X+Y)
  1. SET DOMAIN=$$CHARCHK^DGRRUTL($$KSP^XUPARAM("WHERE"))
  1. ;SET RESTRICT=$G(^VA(200,+$G(DUZ),101))
  1. S DGRRIENS=$$IENS^DILF(+$G(DUZ))
  1. D GETS^DIQ(200,DGRRIENS,"101.01;101.02","I","DGRRLIST")
  1. S RESTRICT=$G(DGRRLIST(200,DGRRIENS,101.01,"I"))_U_$G(DGRRLIST(200,DGRRIENS,101.02,"I"))
  1. IF +RESTRICT S CODE="I $D(^OR(100.21,"_$P(RESTRICT,"^",2)_",10,""B"",+$G(DFN)_"";DPT(""))"
  1. ;.IF MSCREEN'="" S MSCREEN=" "_CODE Q
  1. ;.IF MSCREEN="" S MSCREEN=CODE
  1. IF (FILTER'=""),(FILTERV'="") DO BYFILTER^DGRRLU0(FILTER,FILTERV,BDATE,EDATE,SEARCH,VALUE,DELIM) GOTO DONE1
  1. IF (SEARCH="PRVLUP") DO PRVLUP^DGRRLU5(.RESULT,.PARAMS) GOTO DONE1
  1. IF (SEARCH="NAME"),($G(PARAMS("VERSION 1"))="") DO BYNAME^DGRRLU6 GOTO DONE1 ; v2 sgg 05/06/04
  1. DO ADD("<record count='0'>")
  1. SET LINENO=DGRRLINE
  1. IF SEARCH="DFN" D Q:$G(DGERR)=1
  1. .D DFNLST(VALUE)
  1. .I $G(DGERR)=1 D DONE1
  1. IF (SEARCH="NAME")!(SEARCH="SSN")!(SEARCH="ICN")!(SEARCH="SSN4") D BYNAME I $G(DGERR)=1 G DONE1 ; ****
  1. IF ("|NAME|SSN|ICN|SSN4|DFN|PRVLUP|"'[SEARCH)!(SEARCH="") DO GOTO DONE1 ; *****
  1. . DO ADD("<error message='Searching for patients by "_$S(SEARCH="":"Empty String",1:SEARCH)_" not yet implemented!'></error>") ; ****
  1. ;
  1. D DONE
  1. IF CANCEL=1 DO CLEAN^DILF ; ****
  1. QUIT
  1. ;
  1. BYNAME ;
  1. NEW FULLCNT,DGRR,NODE,DFN,XREF,DIERR
  1. ;; copied From scutbk11
  1. ;; DO FIND^DIC(2,,".01;.03;.363;.09","PS",VALUE,300,"B^BS^BS5^SSN")
  1. ;
  1. IF VALUE="" DO Q
  1. . DO ADD("<error message='Not Enough Information Provided to Search for Patients. Search Type = """_SEARCH_""" Search For = """_VALUE_"""'></error>")
  1. . S DGERR=1
  1. ;
  1. IF SEARCH="NAME" SET XREF="B^NOP" IF VALUE[", " DO
  1. . SET VALUE=$P(VALUE,", ")_","_$P(VALUE,", ",2) ;REMOVE FIRST SPACE
  1. IF SEARCH="SSN" SET XREF="SSN",VALUE=$TR(VALUE," -","") ; REMOVE DASHES AND SPACES
  1. IF SEARCH="SSN4" SET XREF="BS5" DO
  1. . IF $L(VALUE)>5 SET VALUE=$E(VALUE,1,5) ; can't exceed 5 characters, if P for psuedo on end take it off.
  1. IF SEARCH="ICN" SET XREF="AICN" DO
  1. . SET VALUE=$P(VALUE,"V",1)
  1. IF $D(^XTMP("DGRRLU",JOB,1)) S CANCEL=1 Q ; *****
  1. ;DO FIND^DIC(2,,".01;.03;.09","PS",VALUE,300,XREF) ; replaced sgg 05/04/04
  1. ;DO FIND^DIC(2,,".01;.03;.09","PS",VALUE,MAXSIZE+3,XREF)
  1. ;IF $G(DIERR) DO Q
  1. ;. DO ADD("<error message='Error occurred in ""Mumps"" during patient lookup'></error>")
  1. ;. DO CLEAN^DILF
  1. ;. S DGERR=1
  1. ;SET FULLCNT=+$G(^TMP("DILIST",$J,0))
  1. ;DO ADD("<record count='0'>")
  1. ;SET LINENO=DGRRLINE
  1. ;
  1. K ^TMP($J,"DGRRPTS")
  1. N DGRRARRY,DGRRLST,DGRRI,DPTPSREF
  1. S DGRRARRY="^TMP($J,""DGRRPTS"")"
  1. ; Set variable to cross references to be used by $$LIST^DPTLK1 call
  1. S DPTPSREF=$TR(XREF,"^",",")
  1. S DGRRLST=$$LIST^DPTLK1(VALUE,MAXSIZE,DGRRARRY)
  1. S DGRRI=0
  1. F S DGRRI=$O(^TMP($J,"DGRRPTS",DGRRI)) Q:'DGRRI D Q:$$STOP^XOBVLIB() Q:CANCEL=1
  1. .N DGRRCA
  1. .S NODE=$G(^TMP($J,"DGRRPTS",DGRRI))
  1. .S DFN=$P(NODE,"^")
  1. .I $P(NODE,"^",2)'=$P(NODE,"^",3) S DGRRCA=1_"^"_$P(NODE,"^",3)
  1. .D PTDATA^DGRRLUA(+NODE,.DGRRPCNT)
  1. .I $D(^XTMP("DGRRLU",JOB,1)) S CANCEL=1
  1. ;
  1. ;FOR DGRR=1:1:FULLCNT D Q:$$STOP^XOBVLIB() Q:CANCEL=1 ; ****
  1. ;. SET NODE=^TMP("DILIST",$J,DGRR,0)
  1. ;. SET DFN=$P(NODE,"^",1)
  1. ;. D PTDATA^DGRRLUA(+NODE,.DGRRPCNT)
  1. ;. IF $D(^XTMP("DGRRLU",JOB,1)) S CANCEL=1 ; *****
  1. K ^TMP($J,"DGRRPTS")
  1. Q
  1. ;
  1. DONE IF CANCEL=1 Q ; *****
  1. IF ($G(MAXSIZRE)<1) DO ADD("<maximum message=''></maximum>") ; sgg moved one line to maintain consistent order
  1. DO ADD("<error message=''>"_$G(ERRMSG)_"</error>")
  1. SET @DGRRESLT@(LINENO)="<record count='"_DGRRPCNT_"'>"
  1. ;
  1. DONE1 D ADD("<institution name='"_SITENM_"' number='"_SITENO_"' productiondatabase='"_PRODSTAT_"' domain='"_DOMAIN_"' ></institution>")
  1. IF (SEARCH="PRVLUP") DO ADD("</persons>")
  1. ;IF (SEARCH="NAME")!(SEARCH="SSN")!(SEARCH="ICN")!(SEARCH="SSN4") DO ADD("</record>")
  1. IF (SEARCH'="PRVLUP") DO ADD("</record>")
  1. QUIT
  1. ;
  1. ADD(STR) ; -- add string to array
  1. SET DGRRLINE=DGRRLINE+1
  1. SET @DGRRESLT@(DGRRLINE)=STR
  1. QUIT
  1. ;
  1. CANCEL(RESULT,PARAM) ; Cancel a patient search ; ****
  1. S JOB=$G(PARAM) ; ****
  1. I JOB="" S RESULT=0 Q
  1. N DGRRCDT
  1. S DGRRCDT=$$FMADD^XLFDT(DT,2)
  1. S ^XTMP("DGRRLU",JOB,0)=DGRRCDT_"^"_DT ; ****
  1. S ^XTMP("DGRRLU",JOB,1)=JOB ; ****
  1. S RESULT=1
  1. Q ; ****
  1. ;
  1. DFNLST(DGRRVAL) ;Loop through DFN list
  1. ;
  1. N DGRRDFN,DGRRI
  1. IF DGRRVAL="" DO Q
  1. . DO ADD("<error message='Not Enough Information Provided to Search for Patients. Search Type = """_SEARCH_""" Search For = """_DGRRVAL_"""'></error>")
  1. . S DGERR=1
  1. F DGRRI=1:1 S DGRRDFN=$P(DGRRVAL,U,DGRRI) Q:DGRRDFN="" D
  1. .I $D(^DPT(+DGRRDFN,0)) D
  1. ..D PTDATA^DGRRLUA(+DGRRDFN,.DGRRPCNT)
  1. Q
  1. ;