source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRRLU.m@ 1141

Last change on this file since 1141 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 6.8 KB
Line 
1DGRRLU ;alb/aas - DG Replacement and Rehosting RPC for VADPT ;12/22/05 14:53
2 ;;5.3;Registration;**538**;Aug 13, 1993
3 ;
4 SET X="You Can't Enter DGRRLU at top of routine!"
5 QUIT
6 ;
7SEARCH(RESULT,PARAMS) ; -- return patient data in XML format
8 ; -- RPC: DGRR PATIENT LOOKUP SEARCH
9 ;
10 ; -- input PARAMS ARRAY
11 ; PARAMS("SEARCH_TYPE") = "NAME","SSN","ICN","SSN4","DFN", "PRVLUP"
12 ; PARAMS("SEARCH_VALUE") = value to search for.
13 ; PARAMS("JOB") = a unique job # used to check for cancelled jobs
14 ;
15 NEW I,X,Y,DGRRAPTS,DGRRIENS,DGRRPCNT,DGRRLINE,DGRRLIST,DGRRESLT,SEARCH,VALUE,FILTER,FILTERV,BDATE,EDATE,CODE,CANCEL,JOB ; ****
16 NEW MAXSIZE,MAXSIZRE,LINENO,DELIM,DOMAIN,RESTRICT,ERRMSG,SITENM,SITENO,PRODSTAT,DGERR
17 ; NEW MSCREEN ; references to MSCREEN removed by sgg 05/06/04 advised by babul no longer required
18 IF '$D(DT) D DT^DICRW
19 KILL RESULT
20 SET DGRRPCNT=0
21 SET DGRRLINE=0
22 K ^TMP($J,"PLU-SEARCH")
23 SET DGRRESLT="^TMP($J,""PLU-SEARCH"")"
24 SET RESULT=$NA(@DGRRESLT)
25 DO ADD($$XMLHDR^DGRRUTL)
26 ;
27 SET CANCEL=0 ; ****
28 SET SEARCH=$$UP^XLFSTR($GET(PARAMS("SEARCH_TYPE")))
29 SET VALUE=$$UP^XLFSTR($GET(PARAMS("SEARCH_VALUE")))
30 SET MAXSIZE=+$GET(PARAMS("MAX_PATIENTS"),50),MAXSIZRE=0
31 ;
32 IF (MAXSIZE<5) SET MAXSIZE=5
33 IF (MAXSIZE>100) SET MAXSIZE=100
34 ;
35 SET FILTER=$$UP^XLFSTR($GET(PARAMS("FILTER_TYPE")))
36 SET FILTERV=$G(PARAMS("FILTER_VALUE"))
37 SET BDATE=$G(PARAMS("CLINIC_STARTDATE"))
38 SET EDATE=$G(PARAMS("CLINIC_ENDDATE"))
39 SET JOB=$G(PARAMS("JOB")) ; ****
40 I JOB="" S JOB=0 ; **** Until Job parameter is used
41 ;SET MSCREEN=$$UP^XLFSTR($G(PARAMS("MSCREEN")))
42 ;IF MSCREEN'="" DO
43 ;. SET X=MSCREEN D ^DIM IF $D(X)=0 SET MSCREEN="" SET ERRMSG="MSCREEN is invalid M code" Q
44 ;. IF $E(MSCREEN)'="I" SET MSCREEN="" SET ERRMSG="MSCREEN Deleted, must start with an If statement." Q
45 ;. IF MSCREEN[" S "!(MSCREEN[" SET ")!(MSCREEN[" S:")!(MSCREEN["SET:") SET MSCREEN="" SET ERRMSG="MSCREEN Deleted, can not set values." Q
46 ;. IF MSCREEN[" K "!(MSCREEN[" KILL ")!(MSCREEN[" K:")!(MSCREEN["SET:") SET MSCREEN="" SET ERRMSG="MSCREEN Deleted, can not kill values." Q
47 ;. IF MSCREEN[" W "!(MSCREEN[" WRITE ")!(MSCREEN[" W:")!(MSCREEN["WRITE:") SET MSCREEN="" SET ERRMSG="MSCREEN Deleted, can not WRITE." Q
48 SET DELIM=$G(PARAMS("DELIMITER"),",") ; Defaults to comma to support old way.
49 ;
50 SET SITENM=$$CHARCHK^DGRRUTL($$SITENAM^DGRRUTL())
51 SET SITENO=$$CHARCHK^DGRRUTL($$SITENO^DGRRUTL())
52 SET X=$$PRODST1^DGRRUTL()
53 SET Y=$$PRODST2^DGRRUTL()
54 SET PRODSTAT=$$CHARCHK^DGRRUTL(X+Y)
55 SET DOMAIN=$$CHARCHK^DGRRUTL($$KSP^XUPARAM("WHERE"))
56 ;SET RESTRICT=$G(^VA(200,+$G(DUZ),101))
57 S DGRRIENS=$$IENS^DILF(+$G(DUZ))
58 D GETS^DIQ(200,DGRRIENS,"101.01;101.02","I","DGRRLIST")
59 S RESTRICT=$G(DGRRLIST(200,DGRRIENS,101.01,"I"))_U_$G(DGRRLIST(200,DGRRIENS,101.02,"I"))
60 IF +RESTRICT S CODE="I $D(^OR(100.21,"_$P(RESTRICT,"^",2)_",10,""B"",+$G(DFN)_"";DPT(""))"
61 ;.IF MSCREEN'="" S MSCREEN=" "_CODE Q
62 ;.IF MSCREEN="" S MSCREEN=CODE
63 IF (FILTER'=""),(FILTERV'="") DO BYFILTER^DGRRLU0(FILTER,FILTERV,BDATE,EDATE,SEARCH,VALUE,DELIM) GOTO DONE1
64 IF (SEARCH="PRVLUP") DO PRVLUP^DGRRLU5(.RESULT,.PARAMS) GOTO DONE1
65 IF (SEARCH="NAME"),($G(PARAMS("VERSION 1"))="") DO BYNAME^DGRRLU6 GOTO DONE1 ; v2 sgg 05/06/04
66 DO ADD("<record count='0'>")
67 SET LINENO=DGRRLINE
68 IF SEARCH="DFN" D Q:$G(DGERR)=1
69 .D DFNLST(VALUE)
70 .I $G(DGERR)=1 D DONE1
71 IF (SEARCH="NAME")!(SEARCH="SSN")!(SEARCH="ICN")!(SEARCH="SSN4") D BYNAME I $G(DGERR)=1 G DONE1 ; ****
72 IF ("|NAME|SSN|ICN|SSN4|DFN|PRVLUP|"'[SEARCH)!(SEARCH="") DO GOTO DONE1 ; *****
73 . DO ADD("<error message='Searching for patients by "_$S(SEARCH="":"Empty String",1:SEARCH)_" not yet implemented!'></error>") ; ****
74 ;
75 D DONE
76 IF CANCEL=1 DO CLEAN^DILF ; ****
77 QUIT
78 ;
79BYNAME ;
80 NEW FULLCNT,DGRR,NODE,DFN,XREF,DIERR
81 ;; copied From scutbk11
82 ;; DO FIND^DIC(2,,".01;.03;.363;.09","PS",VALUE,300,"B^BS^BS5^SSN")
83 ;
84 IF VALUE="" DO Q
85 . DO ADD("<error message='Not Enough Information Provided to Search for Patients. Search Type = """_SEARCH_""" Search For = """_VALUE_"""'></error>")
86 . S DGERR=1
87 ;
88 IF SEARCH="NAME" SET XREF="B^NOP" IF VALUE[", " DO
89 . SET VALUE=$P(VALUE,", ")_","_$P(VALUE,", ",2) ;REMOVE FIRST SPACE
90 IF SEARCH="SSN" SET XREF="SSN",VALUE=$TR(VALUE," -","") ; REMOVE DASHES AND SPACES
91 IF SEARCH="SSN4" SET XREF="BS5" DO
92 . IF $L(VALUE)>5 SET VALUE=$E(VALUE,1,5) ; can't exceed 5 characters, if P for psuedo on end take it off.
93 IF SEARCH="ICN" SET XREF="AICN" DO
94 . SET VALUE=$P(VALUE,"V",1)
95 IF $D(^XTMP("DGRRLU",JOB,1)) S CANCEL=1 Q ; *****
96 ;DO FIND^DIC(2,,".01;.03;.09","PS",VALUE,300,XREF) ; replaced sgg 05/04/04
97 ;DO FIND^DIC(2,,".01;.03;.09","PS",VALUE,MAXSIZE+3,XREF)
98 ;IF $G(DIERR) DO Q
99 ;. DO ADD("<error message='Error occurred in ""Mumps"" during patient lookup'></error>")
100 ;. DO CLEAN^DILF
101 ;. S DGERR=1
102 ;SET FULLCNT=+$G(^TMP("DILIST",$J,0))
103 ;DO ADD("<record count='0'>")
104 ;SET LINENO=DGRRLINE
105 ;
106 K ^TMP($J,"DGRRPTS")
107 N DGRRARRY,DGRRLST,DGRRI,DPTPSREF
108 S DGRRARRY="^TMP($J,""DGRRPTS"")"
109 ; Set variable to cross references to be used by $$LIST^DPTLK1 call
110 S DPTPSREF=$TR(XREF,"^",",")
111 S DGRRLST=$$LIST^DPTLK1(VALUE,MAXSIZE,DGRRARRY)
112 S DGRRI=0
113 F S DGRRI=$O(^TMP($J,"DGRRPTS",DGRRI)) Q:'DGRRI D Q:$$STOP^XOBVLIB() Q:CANCEL=1
114 .N DGRRCA
115 .S NODE=$G(^TMP($J,"DGRRPTS",DGRRI))
116 .S DFN=$P(NODE,"^")
117 .I $P(NODE,"^",2)'=$P(NODE,"^",3) S DGRRCA=1_"^"_$P(NODE,"^",3)
118 .D PTDATA^DGRRLUA(+NODE,.DGRRPCNT)
119 .I $D(^XTMP("DGRRLU",JOB,1)) S CANCEL=1
120 ;
121 ;FOR DGRR=1:1:FULLCNT D Q:$$STOP^XOBVLIB() Q:CANCEL=1 ; ****
122 ;. SET NODE=^TMP("DILIST",$J,DGRR,0)
123 ;. SET DFN=$P(NODE,"^",1)
124 ;. D PTDATA^DGRRLUA(+NODE,.DGRRPCNT)
125 ;. IF $D(^XTMP("DGRRLU",JOB,1)) S CANCEL=1 ; *****
126 K ^TMP($J,"DGRRPTS")
127 Q
128 ;
129DONE IF CANCEL=1 Q ; *****
130 IF ($G(MAXSIZRE)<1) DO ADD("<maximum message=''></maximum>") ; sgg moved one line to maintain consistent order
131 DO ADD("<error message=''>"_$G(ERRMSG)_"</error>")
132 SET @DGRRESLT@(LINENO)="<record count='"_DGRRPCNT_"'>"
133 ;
134DONE1 D ADD("<institution name='"_SITENM_"' number='"_SITENO_"' productiondatabase='"_PRODSTAT_"' domain='"_DOMAIN_"' ></institution>")
135 IF (SEARCH="PRVLUP") DO ADD("</persons>")
136 ;IF (SEARCH="NAME")!(SEARCH="SSN")!(SEARCH="ICN")!(SEARCH="SSN4") DO ADD("</record>")
137 IF (SEARCH'="PRVLUP") DO ADD("</record>")
138 QUIT
139 ;
140ADD(STR) ; -- add string to array
141 SET DGRRLINE=DGRRLINE+1
142 SET @DGRRESLT@(DGRRLINE)=STR
143 QUIT
144 ;
145CANCEL(RESULT,PARAM) ; Cancel a patient search ; ****
146 S JOB=$G(PARAM) ; ****
147 I JOB="" S RESULT=0 Q
148 N DGRRCDT
149 S DGRRCDT=$$FMADD^XLFDT(DT,2)
150 S ^XTMP("DGRRLU",JOB,0)=DGRRCDT_"^"_DT ; ****
151 S ^XTMP("DGRRLU",JOB,1)=JOB ; ****
152 S RESULT=1
153 Q ; ****
154 ;
155DFNLST(DGRRVAL) ;Loop through DFN list
156 ;
157 N DGRRDFN,DGRRI
158 IF DGRRVAL="" DO Q
159 . DO ADD("<error message='Not Enough Information Provided to Search for Patients. Search Type = """_SEARCH_""" Search For = """_DGRRVAL_"""'></error>")
160 . S DGERR=1
161 F DGRRI=1:1 S DGRRDFN=$P(DGRRVAL,U,DGRRI) Q:DGRRDFN="" D
162 .I $D(^DPT(+DGRRDFN,0)) D
163 ..D PTDATA^DGRRLUA(+DGRRDFN,.DGRRPCNT)
164 Q
165 ;
Note: See TracBrowser for help on using the repository browser.