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

DGRRLU6.m

Go to the documentation of this file. 
  1. DGRRLU6 ;alb/aas - DG Replacement and Rehosting RPC for VADPT ; Jan-7-2003  ; 9/2/08 2:11pm
  1.  ;;5.3;PIMS;**538,1015,1016**;JUN 30, 2012;Build 20
  1.  ;
  1.  ; CALLED BY DGRRLU LINE:
  1.  ; IF (SEARCH="NAME"),($G(PARAMS("VERSION 2"))'="") DO BYNAME^DGRRLU6 ; sgg 05/06/04
  1.  ;
  1.  ;
  1.  ;
  1. BYNAME ; (VALUE)
  1.  NEW FULLCNT,DGRRPCNT,DGRR,NODE,DFN,XREF,DIERR
  1.  ;
  1.  IF SEARCH="NAME" SET XREF="B" IF VALUE[", " 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" 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" SET VALUE=$P(VALUE,"V",1)
  1.  ;
  1.  NEW SGGCOUNT,IEN,QUITFLG,PP,CNTLINE,OVERMAX,MAXMSG,RCLINE,LIMIT,GLOB
  1.  ;
  1.  IF VALUE="" DO  QUIT
  1.  . DO ADD("<record count='0'>")
  1.  . DO ADD("<maximum message=''></maximum>")
  1.  . DO ADD("<error message='Not Enough Information Provided to Search for Patients.  Search Type = """_SEARCH_"""  Search For = """_VALUE_"""'></error>")
  1.  ;
  1.  SET DGRRLINE=DGRRLINE+1,RCLINE=DGRRLINE
  1.  S SGGCOUNT=0,PP=$O(^DPT("B",VALUE),-1),IEN=""
  1.  S LIMIT=MAXSIZE,OVERMAX=0
  1.  SET QUITFLG=0
  1.  F  S PP=$O(^DPT("B",PP)) Q:PP=""  DO  QUIT:QUITFLG
  1.  .IF ($E(PP,1,$L(VALUE))'=VALUE) SET QUITFLG=1 QUIT
  1.  .IF ((LIMIT'="")&(SGGCOUNT+1>LIMIT)) SET QUITFLG=1,OVERMAX=1 QUIT
  1.  .IF $D(^XTMP("DGRRLU",JOB,1)) S QUITFLG=1,CANCEL=1  ; ****
  1.  .IF ($$STOP^XOBVLIB()) SET QUITFLG=1 QUIT
  1.  .F  S IEN=$O(^DPT("B",PP,IEN)) Q:IEN=""  D
  1.  ..S GLOB(0)=$G(^DPT(IEN,0))
  1.  ..;S ^TMP($J,"NAME",IEN)=$P(^DPT(IEN,0),"^",1)
  1.  ..D PTDATA(IEN,SGGCOUNT)
  1.  ..S SGGCOUNT=SGGCOUNT+1
  1.  IF CANCEL=1 QUIT  ; ****
  1.  ;
  1.  SET MAXMSG="" IF +$G(OVERMAX) SET MAXMSG="Too many patients found (more than "_LIMIT_").  Please Limit Search."
  1.  DO ADD("<maximum message='"_MAXMSG_"'></maximum>")
  1.  DO ADD("<error message=''></error>")
  1.  ;
  1.  SET @DGRRESLT@(RCLINE)=("<record count='"_SGGCOUNT_"'>")
  1.  QUIT
  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,PCPIEN,PCPVPID,PCPNAME,PATSPCP
  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 $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.  ; -- 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.  ; -- 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)) ;786
  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_"'></patient>"
  1.  ;
  1.  DO ADD(LINE)
  1.  DO NAMECOMP^DGRRLU0(DFN,DGRRPCNT)
  1.  ;
  1.  QUIT
  1.  ;
  1. MAXOUT ;
  1.  IF $G(MAXSIZRE)<1 DO ADD("<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
  1.  ;
  1. ADD(STR) ; -- add string to array
  1.  SET DGRRLINE=DGRRLINE+1
  1.  SET @DGRRESLT@(DGRRLINE)=STR
  1.  QUIT
  1.  ;
  1. TEST(XSTRING,XNUMBER,DISPLAY) ;
  1.  ; ZL DGRRLU6 D TEST("SMITH",100,1)
  1.  ; DO THE OLD CODE
  1.  N RESULT,PARAMS,AAA,BBB
  1.  SET PARAMS("SEARCH_VALUE")=XSTRING
  1.  SET PARAMS("SEARCH_TYPE")="NAME"
  1.  SET PARAMS("MAX_PATIENTS")=+XNUMBER
  1.  SET PARAMS("VERSION 1")="OLD CODE"
  1.  D SEARCH^DGRRLU(.RESULT,.PARAMS)
  1.  D RESTOT(.RESULT,.AAA)
  1.  IF +$G(DISPLAY) D DISPLAY(.RESULT)
  1.  ; DO THE NEW CODE
  1.  N RESULT,PARAMS
  1.  K PARAMS
  1.  SET PARAMS("SEARCH_VALUE")=XSTRING
  1.  SET PARAMS("SEARCH_TYPE")="NAME"
  1.  SET PARAMS("MAX_PATIENTS")=+XNUMBER
  1.  D SEARCH^DGRRLU(.RESULT,.PARAMS)
  1.  IF +$G(DISPLAY) D DISPLAY(.RESULT)
  1.  D RESTOT(.RESULT,.BBB)
  1.  ;
  1.  ;IF AAA=BBB W !!!,"NO MISMATCH"
  1.  ;IF AAA'=BBB W !!!,"RESULT MISMATCH" DO
  1.  ;.W !!!,"AAA>",AAA
  1.  ;.W !!!,"BBB>",BBB
  1.  ;.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)
  1.  ;
  1.  QUIT
  1.  ;
  1. DISPLAY(RESULT) ;
  1.  NEW I
  1.  S I=-1 FOR  SET I=$O(@RESULT@(I)) Q:I<1  W !!,@RESULT@(I)
  1.  QUIT
  1.  ;
  1. RESTOT(RESULT,OUT) ;
  1.  NEW I
  1.  S OUT="",I=-1 FOR  SET I=$O(@RESULT@(I)) Q:I<1  S OUT(I)=@RESULT@(I)
  1.  QUIT