DGRRLUA ;alb/aas - Person Service Lookup gather patient data;2/15/2005 ; 9/2/08 12:09pm
;;5.3;Registration;**538,786**;Aug 13, 1993;Build 21
;
;DGRRLUA created when DGRRLU exceeded maximum routine size
;
PTDATA(DFN,DGRRPCNT) ;
NEW I,DONE,LINE,ALIAS,NAME,PTNAME,DOB,SSN,TYPE,GENDER,ICN,PRIM,SC,SCPER,VET,WARD,ROOMBED,SENSITIV,DGEMP,PATSPCP,PCPIEN,PCPVPID,PCPNAME
IF DGRRPCNT>(MAXSIZE-1) DO MAXOUT QUIT
;IF (MSCREEN'="") X MSCREEN I '$T Q
SET DGRRPCNT=DGRRPCNT+1
SET LINE="<patient number='"_DGRRPCNT_"' dfn='"_DFN_"'"
;
SET PTNAME=$P(^DPT(DFN,0),"^",1)
IF SEARCH="NAME",FILTER="" IF $P($G(DGRRCA),"^")=1 DO
.I $O(^DPT(DFN,.01,0)) D
.. SET (I,DONE)=0
.. SET ALIAS=""
.. FOR S I=$O(^DPT(DFN,.01,I)) Q:I<1 Q:DONE DO
... SET ALIAS=$P($G(^DPT(DFN,.01,I,0)),"^",1)
... IF ALIAS=$P(DGRRCA,"^",2) SET PTNAME="("_ALIAS_") "_PTNAME,DONE=1
.. IF DONE=0 SET PTNAME="(Unknown Alias) "_PTNAME
;
;IF SEARCH="NAME",FILTER="" IF $E(PTNAME,1,$L(VALUE))'=VALUE DO
;. SET (I,DONE)=0
;. SET ALIAS=""
;. FOR S I=$O(^DPT(DFN,.01,I)) Q:I<1 Q:DONE DO
;.. SET ALIAS=$P($G(^DPT(DFN,.01,I,0)),"^",1)
;.. IF $E(ALIAS,1,$L(VALUE))=VALUE SET PTNAME="("_ALIAS_") "_PTNAME,DONE=1
;. IF DONE=0 SET PTNAME="(Unknown Alias) "_PTNAME
;
; -- REQUIRED COMPONENTS
;SENSITIV will be set to true to block the display of the SSN and DOB
;if patient is marked as sensitive in DG Security Log (#38.1) file or
;has an employee eligibility code
SET SENSITIV=$S($P($G(^DGSL(38.1,DFN,0)),"^",2)=1:"true",1:"false")
I SENSITIV="false" D
.S DGEMP=$$EMPL^DGSEC4(DFN)
.I DGEMP=1 S SENSITIV="true"
SET NAME=$$CHARCHK^DGRRUTL(PTNAME)
SET DOB=$$CHARCHK^DGRRUTL($P($G(^DPT(DFN,0)),"^",3))
SET SSN=$$CHARCHK^DGRRUTL($P($G(^DPT(DFN,0)),"^",9))
SET LINE=LINE_" sensitive='"_SENSITIV_"' name='"_NAME_"' dob='"_DOB_"' ssn='"_SSN_"' "
;
; -- OPTIONAL COMPONENTS
;Patient Type (391)
SET TYPE=$$CHARCHK^DGRRUTL($P($G(^DG(391,+$G(^DPT(DFN,"TYPE")),0)),"^",1))
;
;gender
SET GENDER=$$CHARCHK^DGRRUTL($P($G(^DPT(DFN,0)),"^",2))
;
;icn
SET ICN=$$ICNLC^MPIF001(DFN)
;
;Primary Eligibility(.361)
SET PRIM=$$PRIM(DFN)
;
SET SC=$P($G(^DPT(DFN,.3)),"^",1,2) ;Is Service Connected (.301) %=.302
SET SCPER=$P(SC,"^",2)
IF $P(SC,"^",1)="Y" SET SC="true"
IF $P(SC,"^",1)="N" SET SC="false"
;
SET VET=$P($G(^DPT(DFN,"VET")),"^",1) ;Veteran Status (1901)
IF VET="Y" SET VET="true"
IF VET="N" SET VET="false"
;
SET WARD=$$CHARCHK^DGRRUTL($E($G(^DPT(DFN,.1)),1,30))
SET ROOMBED=$$CHARCHK^DGRRUTL($P($G(^DPT(DFN,.101)),"^",1))
;
; get the PCP's IEN and convert to VPID (primary care physician) sgg 06/17/04
SET PATSPCP=$$NMPCPR^SCAPMCU2(DFN,DT,1)
SET PCPIEN=$P(PATSPCP,"^",1)
SET PCPNAME=$$CHARCHK^DGRRUTL($P(PATSPCP,"^",2))
SET PCPVPID=$$VPID^XUPS(+PCPIEN)
;
SET LINE=LINE_" type='"_TYPE_"' primaryeligibility='"_PRIM_"' serviceconnected='"_SC_"' scpercent='"_SCPER_"'"
SET LINE=LINE_" gender='"_GENDER_"' icn='"_ICN_"' veteran='"_VET_"' ward='"_WARD_"' roombed='"_ROOMBED_"'"
SET LINE=LINE_" pcpien='"_PCPIEN_"' pcpvpid='"_PCPVPID_"' pcpname='"_PCPNAME_"'>"
I +$G(DGRRAPTS)=0 S LINE=LINE_"</patient>"
;
DO ADD^DGRRUTL(LINE)
;
DO NAMECOMP^DGRRLU0(DFN,DGRRPCNT)
;
QUIT
;
MAXOUT ;
IF $G(MAXSIZRE)<1 DO ADD^DGRRUTL("<maximum message='Too many patients found (more than "_MAXSIZE_"). Please Limit Search.'></maximum>")
SET MAXSIZRE=1
QUIT
;
PRIM(DFN) ; -- returns print name from file 8.1
NEW PRIM1
SET PRIM1=$P($G(^DIC(8,+$G(^DPT(DFN,.36)),0)),"^",9) ; station entry
Q $$CHARCHK^DGRRUTL($P($G(^DIC(8.1,+PRIM1,0)),"^",6)) ; mas entry
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRRLUA 3655 printed Sep 23, 2025@20:33:34 Page 2
DGRRLUA ;alb/aas - Person Service Lookup gather patient data;2/15/2005 ; 9/2/08 12:09pm
+1 ;;5.3;Registration;**538,786**;Aug 13, 1993;Build 21
+2 ;
+3 ;DGRRLUA created when DGRRLU exceeded maximum routine size
+4 ;
PTDATA(DFN,DGRRPCNT) ;
+1 NEW I,DONE,LINE,ALIAS,NAME,PTNAME,DOB,SSN,TYPE,GENDER,ICN,PRIM,SC,SCPER,VET,WARD,ROOMBED,SENSITIV,DGEMP,PATSPCP,PCPIEN,PCPVPID,PCPNAME
+2 IF DGRRPCNT>(MAXSIZE-1)
DO MAXOUT
QUIT
+3 ;IF (MSCREEN'="") X MSCREEN I '$T Q
+4 SET DGRRPCNT=DGRRPCNT+1
+5 SET LINE="<patient number='"_DGRRPCNT_"' dfn='"_DFN_"'"
+6 ;
+7 SET PTNAME=$PIECE(^DPT(DFN,0),"^",1)
+8 IF SEARCH="NAME"
IF FILTER=""
IF $PIECE($GET(DGRRCA),"^")=1
Begin DoDot:1
+9 IF $ORDER(^DPT(DFN,.01,0))
Begin DoDot:2
+10 SET (I,DONE)=0
+11 SET ALIAS=""
+12 FOR
SET I=$ORDER(^DPT(DFN,.01,I))
if I<1
QUIT
if DONE
QUIT
Begin DoDot:3
+13 SET ALIAS=$PIECE($GET(^DPT(DFN,.01,I,0)),"^",1)
+14 IF ALIAS=$PIECE(DGRRCA,"^",2)
SET PTNAME="("_ALIAS_") "_PTNAME
SET DONE=1
End DoDot:3
+15 IF DONE=0
SET PTNAME="(Unknown Alias) "_PTNAME
End DoDot:2
End DoDot:1
+16 ;
+17 ;IF SEARCH="NAME",FILTER="" IF $E(PTNAME,1,$L(VALUE))'=VALUE DO
+18 ;. SET (I,DONE)=0
+19 ;. SET ALIAS=""
+20 ;. FOR S I=$O(^DPT(DFN,.01,I)) Q:I<1 Q:DONE DO
+21 ;.. SET ALIAS=$P($G(^DPT(DFN,.01,I,0)),"^",1)
+22 ;.. IF $E(ALIAS,1,$L(VALUE))=VALUE SET PTNAME="("_ALIAS_") "_PTNAME,DONE=1
+23 ;. IF DONE=0 SET PTNAME="(Unknown Alias) "_PTNAME
+24 ;
+25 ; -- REQUIRED COMPONENTS
+26 ;SENSITIV will be set to true to block the display of the SSN and DOB
+27 ;if patient is marked as sensitive in DG Security Log (#38.1) file or
+28 ;has an employee eligibility code
+29 SET SENSITIV=$SELECT($PIECE($GET(^DGSL(38.1,DFN,0)),"^",2)=1:"true",1:"false")
+30 IF SENSITIV="false"
Begin DoDot:1
+31 SET DGEMP=$$EMPL^DGSEC4(DFN)
+32 IF DGEMP=1
SET SENSITIV="true"
End DoDot:1
+33 SET NAME=$$CHARCHK^DGRRUTL(PTNAME)
+34 SET DOB=$$CHARCHK^DGRRUTL($PIECE($GET(^DPT(DFN,0)),"^",3))
+35 SET SSN=$$CHARCHK^DGRRUTL($PIECE($GET(^DPT(DFN,0)),"^",9))
+36 SET LINE=LINE_" sensitive='"_SENSITIV_"' name='"_NAME_"' dob='"_DOB_"' ssn='"_SSN_"' "
+37 ;
+38 ; -- OPTIONAL COMPONENTS
+39 ;Patient Type (391)
+40 SET TYPE=$$CHARCHK^DGRRUTL($PIECE($GET(^DG(391,+$GET(^DPT(DFN,"TYPE")),0)),"^",1))
+41 ;
+42 ;gender
+43 SET GENDER=$$CHARCHK^DGRRUTL($PIECE($GET(^DPT(DFN,0)),"^",2))
+44 ;
+45 ;icn
+46 SET ICN=$$ICNLC^MPIF001(DFN)
+47 ;
+48 ;Primary Eligibility(.361)
+49 SET PRIM=$$PRIM(DFN)
+50 ;
+51 ;Is Service Connected (.301) %=.302
SET SC=$PIECE($GET(^DPT(DFN,.3)),"^",1,2)
+52 SET SCPER=$PIECE(SC,"^",2)
+53 IF $PIECE(SC,"^",1)="Y"
SET SC="true"
+54 IF $PIECE(SC,"^",1)="N"
SET SC="false"
+55 ;
+56 ;Veteran Status (1901)
SET VET=$PIECE($GET(^DPT(DFN,"VET")),"^",1)
+57 IF VET="Y"
SET VET="true"
+58 IF VET="N"
SET VET="false"
+59 ;
+60 SET WARD=$$CHARCHK^DGRRUTL($EXTRACT($GET(^DPT(DFN,.1)),1,30))
+61 SET ROOMBED=$$CHARCHK^DGRRUTL($PIECE($GET(^DPT(DFN,.101)),"^",1))
+62 ;
+63 ; get the PCP's IEN and convert to VPID (primary care physician) sgg 06/17/04
+64 SET PATSPCP=$$NMPCPR^SCAPMCU2(DFN,DT,1)
+65 SET PCPIEN=$PIECE(PATSPCP,"^",1)
+66 SET PCPNAME=$$CHARCHK^DGRRUTL($PIECE(PATSPCP,"^",2))
+67 SET PCPVPID=$$VPID^XUPS(+PCPIEN)
+68 ;
+69 SET LINE=LINE_" type='"_TYPE_"' primaryeligibility='"_PRIM_"' serviceconnected='"_SC_"' scpercent='"_SCPER_"'"
+70 SET LINE=LINE_" gender='"_GENDER_"' icn='"_ICN_"' veteran='"_VET_"' ward='"_WARD_"' roombed='"_ROOMBED_"'"
+71 SET LINE=LINE_" pcpien='"_PCPIEN_"' pcpvpid='"_PCPVPID_"' pcpname='"_PCPNAME_"'>"
+72 IF +$GET(DGRRAPTS)=0
SET LINE=LINE_"</patient>"
+73 ;
+74 DO ADD^DGRRUTL(LINE)
+75 ;
+76 DO NAMECOMP^DGRRLU0(DFN,DGRRPCNT)
+77 ;
+78 QUIT
+79 ;
MAXOUT ;
+1 IF $GET(MAXSIZRE)<1
DO ADD^DGRRUTL("<maximum message='Too many patients found (more than "_MAXSIZE_"). Please Limit Search.'></maximum>")
+2 SET MAXSIZRE=1
+3 QUIT
+4 ;
PRIM(DFN) ; -- returns print name from file 8.1
+1 NEW PRIM1
+2 ; station entry
SET PRIM1=$PIECE($GET(^DIC(8,+$GET(^DPT(DFN,.36)),0)),"^",9)
+3 ; mas entry
QUIT $$CHARCHK^DGRRUTL($PIECE($GET(^DIC(8.1,+PRIM1,0)),"^",6))
