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

DGRRLUA.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;DGRRLUA created when DGRRLU exceeded maximum routine size
  1. ;
  1. 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
  1. IF DGRRPCNT>(MAXSIZE-1) DO MAXOUT QUIT
  1. ;IF (MSCREEN'="") X MSCREEN I '$T Q
  1. SET DGRRPCNT=DGRRPCNT+1
  1. SET LINE="<patient number='"_DGRRPCNT_"' dfn='"_DFN_"'"
  1. ;
  1. SET PTNAME=$P(^DPT(DFN,0),"^",1)
  1. IF SEARCH="NAME",FILTER="" IF $P($G(DGRRCA),"^")=1 DO
  1. .I $O(^DPT(DFN,.01,0)) D
  1. .. SET (I,DONE)=0
  1. .. SET ALIAS=""
  1. .. FOR S I=$O(^DPT(DFN,.01,I)) Q:I<1 Q:DONE DO
  1. ... SET ALIAS=$P($G(^DPT(DFN,.01,I,0)),"^",1)
  1. ... IF ALIAS=$P(DGRRCA,"^",2) SET PTNAME="("_ALIAS_") "_PTNAME,DONE=1
  1. .. IF DONE=0 SET PTNAME="(Unknown Alias) "_PTNAME
  1. ;
  1. ;IF SEARCH="NAME",FILTER="" IF $E(PTNAME,1,$L(VALUE))'=VALUE DO
  1. ;. SET (I,DONE)=0
  1. ;. SET ALIAS=""
  1. ;. FOR S I=$O(^DPT(DFN,.01,I)) Q:I<1 Q:DONE DO
  1. ;.. SET ALIAS=$P($G(^DPT(DFN,.01,I,0)),"^",1)
  1. ;.. IF $E(ALIAS,1,$L(VALUE))=VALUE SET PTNAME="("_ALIAS_") "_PTNAME,DONE=1
  1. ;. IF DONE=0 SET PTNAME="(Unknown Alias) "_PTNAME
  1. ;
  1. ; -- REQUIRED COMPONENTS
  1. ;SENSITIV will be set to true to block the display of the SSN and DOB
  1. ;if patient is marked as sensitive in DG Security Log (#38.1) file or
  1. ;has an employee eligibility code
  1. SET SENSITIV=$S($P($G(^DGSL(38.1,DFN,0)),"^",2)=1:"true",1:"false")
  1. I SENSITIV="false" D
  1. .S DGEMP=$$EMPL^DGSEC4(DFN)
  1. .I DGEMP=1 S SENSITIV="true"
  1. SET NAME=$$CHARCHK^DGRRUTL(PTNAME)
  1. SET DOB=$$CHARCHK^DGRRUTL($P($G(^DPT(DFN,0)),"^",3))
  1. SET SSN=$$CHARCHK^DGRRUTL($P($G(^DPT(DFN,0)),"^",9))
  1. SET LINE=LINE_" sensitive='"_SENSITIV_"' name='"_NAME_"' dob='"_DOB_"' ssn='"_SSN_"' "
  1. ;
  1. ; -- OPTIONAL COMPONENTS
  1. ;Patient Type (391)
  1. SET TYPE=$$CHARCHK^DGRRUTL($P($G(^DG(391,+$G(^DPT(DFN,"TYPE")),0)),"^",1))
  1. ;
  1. ;gender
  1. SET GENDER=$$CHARCHK^DGRRUTL($P($G(^DPT(DFN,0)),"^",2))
  1. ;
  1. ;icn
  1. SET ICN=$$ICNLC^MPIF001(DFN)
  1. ;
  1. ;Primary Eligibility(.361)
  1. SET PRIM=$$PRIM(DFN)
  1. ;
  1. SET SC=$P($G(^DPT(DFN,.3)),"^",1,2) ;Is Service Connected (.301) %=.302
  1. SET SCPER=$P(SC,"^",2)
  1. IF $P(SC,"^",1)="Y" SET SC="true"
  1. IF $P(SC,"^",1)="N" SET SC="false"
  1. ;
  1. SET VET=$P($G(^DPT(DFN,"VET")),"^",1) ;Veteran Status (1901)
  1. IF VET="Y" SET VET="true"
  1. IF VET="N" SET VET="false"
  1. ;
  1. SET WARD=$$CHARCHK^DGRRUTL($E($G(^DPT(DFN,.1)),1,30))
  1. SET ROOMBED=$$CHARCHK^DGRRUTL($P($G(^DPT(DFN,.101)),"^",1))
  1. ;
  1. ; get the PCP's IEN and convert to VPID (primary care physician) sgg 06/17/04
  1. SET PATSPCP=$$NMPCPR^SCAPMCU2(DFN,DT,1)
  1. SET PCPIEN=$P(PATSPCP,"^",1)
  1. SET PCPNAME=$$CHARCHK^DGRRUTL($P(PATSPCP,"^",2))
  1. SET PCPVPID=$$VPID^XUPS(+PCPIEN)
  1. ;
  1. SET LINE=LINE_" type='"_TYPE_"' primaryeligibility='"_PRIM_"' serviceconnected='"_SC_"' scpercent='"_SCPER_"'"
  1. SET LINE=LINE_" gender='"_GENDER_"' icn='"_ICN_"' veteran='"_VET_"' ward='"_WARD_"' roombed='"_ROOMBED_"'"
  1. SET LINE=LINE_" pcpien='"_PCPIEN_"' pcpvpid='"_PCPVPID_"' pcpname='"_PCPNAME_"'>"
  1. I +$G(DGRRAPTS)=0 S LINE=LINE_"</patient>"
  1. ;
  1. DO ADD^DGRRUTL(LINE)
  1. ;
  1. DO NAMECOMP^DGRRLU0(DFN,DGRRPCNT)
  1. ;
  1. QUIT
  1. ;
  1. MAXOUT ;
  1. IF $G(MAXSIZRE)<1 DO ADD^DGRRUTL("<maximum message='Too many patients found (more than "_MAXSIZE_"). Please Limit Search.'></maximum>")
  1. SET MAXSIZRE=1
  1. QUIT
  1. ;
  1. PRIM(DFN) ; -- returns print name from file 8.1
  1. NEW PRIM1
  1. SET PRIM1=$P($G(^DIC(8,+$G(^DPT(DFN,.36)),0)),"^",9) ; station entry
  1. Q $$CHARCHK^DGRRUTL($P($G(^DIC(8.1,+PRIM1,0)),"^",6)) ; mas entry