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

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

initial load of WorldVistAEHR

File size: 5.9 KB
RevLine 
[613]1DGRRLU6 ;alb/aas - DG Replacement and Rehosting RPC for VADPT ; Jan-7-2003 ; Compiled April 27, 2004 10:10:10
2 ;;5.3;Registration;**538**;Aug 13, 1993
3 ;
4 ; CALLED BY DGRRLU LINE:
5 ; IF (SEARCH="NAME"),($G(PARAMS("VERSION 2"))'="") DO BYNAME^DGRRLU6 ; sgg 05/06/04
6 ;
7 ;
8 ;
9BYNAME ; (VALUE)
10 NEW FULLCNT,DGRRPCNT,DGRR,NODE,DFN,XREF,DIERR
11 ;
12 IF SEARCH="NAME" SET XREF="B" IF VALUE[", " SET VALUE=$P(VALUE,", ")_","_$P(VALUE,", ",2) ;REMOVE FIRST SPACE
13 IF SEARCH="SSN" SET XREF="SSN",VALUE=$TR(VALUE," -","") ; REMOVE DASHES AND SPACES
14 IF SEARCH="SSN4" SET XREF="BS5" IF $L(VALUE)>5 SET VALUE=$E(VALUE,1,5) ; can't exceed 5 characters, if P for psuedo on end take it off.
15 IF SEARCH="ICN" SET XREF="AICN" SET VALUE=$P(VALUE,"V",1)
16 ;
17 NEW SGGCOUNT,IEN,QUITFLG,PP,CNTLINE,OVERMAX,MAXMSG,RCLINE,LIMIT,GLOB
18 ;
19 IF VALUE="" DO QUIT
20 . DO ADD("<record count='0'>")
21 . DO ADD("<maximum message=''></maximum>")
22 . DO ADD("<error message='Not Enough Information Provided to Search for Patients. Search Type = """_SEARCH_""" Search For = """_VALUE_"""'></error>")
23 ;
24 SET DGRRLINE=DGRRLINE+1,RCLINE=DGRRLINE
25 S SGGCOUNT=0,PP=$O(^DPT("B",VALUE),-1),IEN=""
26 S LIMIT=MAXSIZE,OVERMAX=0
27 SET QUITFLG=0
28 F S PP=$O(^DPT("B",PP)) Q:PP="" DO QUIT:QUITFLG
29 .IF ($E(PP,1,$L(VALUE))'=VALUE) SET QUITFLG=1 QUIT
30 .IF ((LIMIT'="")&(SGGCOUNT+1>LIMIT)) SET QUITFLG=1,OVERMAX=1 QUIT
31 .IF $D(^XTMP("DGRRLU",JOB,1)) S QUITFLG=1,CANCEL=1 ; ****
32 .IF ($$STOP^XOBVLIB()) SET QUITFLG=1 QUIT
33 .F S IEN=$O(^DPT("B",PP,IEN)) Q:IEN="" D
34 ..S GLOB(0)=$G(^DPT(IEN,0))
35 ..;S ^TMP($J,"NAME",IEN)=$P(^DPT(IEN,0),"^",1)
36 ..D PTDATA(IEN,SGGCOUNT)
37 ..S SGGCOUNT=SGGCOUNT+1
38 IF CANCEL=1 QUIT ; ****
39 ;
40 SET MAXMSG="" IF +$G(OVERMAX) SET MAXMSG="Too many patients found (more than "_LIMIT_"). Please Limit Search."
41 DO ADD("<maximum message='"_MAXMSG_"'></maximum>")
42 DO ADD("<error message=''></error>")
43 ;
44 SET @DGRRESLT@(RCLINE)=("<record count='"_SGGCOUNT_"'>")
45 QUIT
46 ;
47PTDATA(DFN,DGRRPCNT) ;
48 NEW I,DONE,LINE,ALIAS,NAME,PTNAME,DOB,SSN,TYPE,GENDER,ICN,PRIM,SC,SCPER,VET,WARD,ROOMBED,SENSITIV,DGEMP,PCPIEN,PCPVPID,PCPNAME,PATSPCP
49 IF DGRRPCNT>(MAXSIZE-1) DO MAXOUT QUIT
50 ;IF (MSCREEN'="") X MSCREEN I '$T Q
51 SET DGRRPCNT=DGRRPCNT+1
52 SET LINE="<patient number='"_DGRRPCNT_"' dfn='"_DFN_"'"
53 ;
54 SET PTNAME=$P(^DPT(DFN,0),"^",1)
55 IF SEARCH="NAME",FILTER="" IF $E(PTNAME,1,$L(VALUE))'=VALUE DO
56 . SET (I,DONE)=0
57 . SET ALIAS=""
58 . FOR S I=$O(^DPT(DFN,.01,I)) Q:I<1 Q:DONE DO
59 .. SET ALIAS=$P($G(^DPT(DFN,.01,I,0)),"^",1)
60 .. IF $E(ALIAS,1,$L(VALUE))=VALUE SET PTNAME="("_ALIAS_") "_PTNAME,DONE=1
61 . IF DONE=0 SET PTNAME="(Unknown Alias) "_PTNAME
62 ; -- REQUIRED COMPONENTS
63 ;SENSITIV will be set to true to block the display of the SSN and DOB
64 ;if patient is marked as sensitive in DG Security Log (#38.1) file or
65 ;has an employee eligibility code
66 SET SENSITIV=$S($P($G(^DGSL(38.1,DFN,0)),"^",2)=1:"true",1:"false")
67 I SENSITIV="false" D
68 .S DGEMP=$$EMPL^DGSEC4(DFN)
69 .I DGEMP=1 S SENSITIV="true"
70 SET NAME=$$CHARCHK^DGRRUTL(PTNAME)
71 SET DOB=$$CHARCHK^DGRRUTL($P($G(^DPT(DFN,0)),"^",3))
72 SET SSN=$$CHARCHK^DGRRUTL($P($G(^DPT(DFN,0)),"^",9))
73 SET LINE=LINE_" sensitive='"_SENSITIV_"' name='"_NAME_"' dob='"_DOB_"' ssn='"_SSN_"' "
74 ; -- OPTIONAL COMPONENTS
75 ;Patient Type (391)
76 SET TYPE=$$CHARCHK^DGRRUTL($P($G(^DG(391,+$G(^DPT(DFN,"TYPE")),0)),"^",1))
77 ;
78 ;gender
79 SET GENDER=$$CHARCHK^DGRRUTL($P($G(^DPT(DFN,0)),"^",2))
80 ;
81 ;icn
82 SET ICN=$$ICNLC^MPIF001(DFN)
83 ;
84 ;Primary Eligibility(.361)
85 SET PRIM=$$PRIM(DFN)
86 ;
87 SET SC=$P($G(^DPT(DFN,.3)),"^",1,2) ;Is Service Connected (.301) %=.302
88 SET SCPER=$P(SC,"^",2)
89 IF $P(SC,"^",1)="Y" SET SC="true"
90 IF $P(SC,"^",1)="N" SET SC="false"
91 ;
92 SET VET=$P($G(^DPT(DFN,"VET")),"^",1) ;Veteran Status (1901)
93 IF VET="Y" SET VET="true"
94 IF VET="N" SET VET="false"
95 ;
96 SET WARD=$$CHARCHK^DGRRUTL($E($G(^DPT(DFN,.1)),1,30))
97 SET ROOMBED=$$CHARCHK^DGRRUTL($P($G(^DPT(DFN,.101)),"^",1))
98 ;
99 ; get the PCP's IEN and convert to VPID (primary care physician) sgg 06/17/04
100 SET PATSPCP=$$NMPCPR^SCAPMCU2(DFN,DT,1)
101 SET PCPIEN=$P(PATSPCP,"^",1)
102 SET PCPNAME=$P(PATSPCP,"^",2)
103 SET PCPVPID=$$VPID^XUPS(+PCPIEN)
104 ;
105 SET LINE=LINE_" type='"_TYPE_"' primaryeligibility='"_PRIM_"' serviceconnected='"_SC_"' scpercent='"_SCPER_"'"
106 SET LINE=LINE_" gender='"_GENDER_"' icn='"_ICN_"' veteran='"_VET_"' ward='"_WARD_"' roombed='"_ROOMBED_"'"
107 SET LINE=LINE_" pcpien='"_PCPIEN_"' pcpvpid='"_PCPVPID_"' pcpname='"_PCPNAME_"'></patient>"
108 ;
109 DO ADD(LINE)
110 DO NAMECOMP^DGRRLU0(DFN,DGRRPCNT)
111 ;
112 QUIT
113 ;
114MAXOUT ;
115 IF $G(MAXSIZRE)<1 DO ADD("<maximum message='Too many patients found (more than "_MAXSIZE_"). Please Limit Search.'></maximum>")
116 SET MAXSIZRE=1
117 QUIT
118 ;
119PRIM(DFN) ; -- returns print name from file 8.1
120 NEW PRIM1
121 SET PRIM1=$P($G(^DIC(8,+$G(^DPT(DFN,.36)),0)),"^",9) ; station entry
122 Q $$CHARCHK^DGRRUTL($P($G(^DIC(8.1,+PRIM1,0)),"^",6)) ; mas entry
123 ;
124ADD(STR) ; -- add string to array
125 SET DGRRLINE=DGRRLINE+1
126 SET @DGRRESLT@(DGRRLINE)=STR
127 QUIT
128 ;
129TEST(XSTRING,XNUMBER,DISPLAY) ;
130 ; ZL DGRRLU6 D TEST("SMITH",100,1)
131 ; DO THE OLD CODE
132 N RESULT,PARAMS,AAA,BBB
133 SET PARAMS("SEARCH_VALUE")=XSTRING
134 SET PARAMS("SEARCH_TYPE")="NAME"
135 SET PARAMS("MAX_PATIENTS")=+XNUMBER
136 SET PARAMS("VERSION 1")="OLD CODE"
137 D SEARCH^DGRRLU(.RESULT,.PARAMS)
138 D RESTOT(.RESULT,.AAA)
139 IF +$G(DISPLAY) D DISPLAY(.RESULT)
140 ; DO THE NEW CODE
141 N RESULT,PARAMS
142 K PARAMS
143 SET PARAMS("SEARCH_VALUE")=XSTRING
144 SET PARAMS("SEARCH_TYPE")="NAME"
145 SET PARAMS("MAX_PATIENTS")=+XNUMBER
146 D SEARCH^DGRRLU(.RESULT,.PARAMS)
147 IF +$G(DISPLAY) D DISPLAY(.RESULT)
148 D RESTOT(.RESULT,.BBB)
149 ;
150 ;IF AAA=BBB W !!!,"NO MISMATCH"
151 ;IF AAA'=BBB W !!!,"RESULT MISMATCH" DO
152 ;.W !!!,"AAA>",AAA
153 ;.W !!!,"BBB>",BBB
154 ;.F I=1:1 Q:($E(AAA,I,I+4)="[EOF]") I $E(AAA,I)'=$E(BBB,I) W !,I,"[A",I,"] ",$E(AAA,I),?10,"[B",I,"] ",$E(BBB,I)
155 ;
156 QUIT
157 ;
158DISPLAY(RESULT) ;
159 NEW I
160 S I=-1 FOR SET I=$O(@RESULT@(I)) Q:I<1 W !!,@RESULT@(I)
161 QUIT
162 ;
163RESTOT(RESULT,OUT) ;
164 NEW I
165 S OUT="",I=-1 FOR SET I=$O(@RESULT@(I)) Q:I<1 S OUT(I)=@RESULT@(I)
166 QUIT
Note: See TracBrowser for help on using the repository browser.