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

LRDPAREX.m

Go to the documentation of this file. 
  1. LRDPAREX ;VA/DALOI/FHS -VALIDATE PENDING ORDER FILE PATIENT LOOKUP ;JUL 06, 2010 3:14 PM
  1.  ;;5.2;LAB SERVICE;**153,286,1027**;NOV 01, 1997
  1.  ; Special patient lookup of Lab Orders Pending File
  1.  ; From ^LRDPAREF after patient selection
  1.  ; Initialize array.
  1.  ;  CDT=collection date/time
  1.  ;  DFN=ien of patient in selected file
  1.  ;  DOB=patient's date of birth
  1.  ;  DPF=67^LRT(67,
  1.  ;  LRXDPF=source file (2,67)
  1.  ;  ERROR=0
  1.  ;  PNM=patient name
  1.  ;  RIEN=IEN of ^LRT(67
  1.  ;  RPSITE=primary sending site
  1.  ;  RSITE=sending site
  1.  ;  RSITEN=sending site name
  1.  ;  RUID=specimen unique identifier
  1.  ;  SEX=patient's sex
  1.  ;  SSN=patient's SSN
  1. EN ;
  1.  N DA,DIC,DIE,DIR,DIRUT,DR,DTOUT,DUOUT,DLAYGO
  1.  S PNM=LRSD("PNM"),SSN=LRSD("SSN"),DOB=LRSD("DOB"),SEX=LRSD("SEX")
  1.  ;
  1.  S LRXDPF=LRSD("DPF"),LRXDFN=LRSD("DFN"),LRDPF="67^LRT(67,"
  1.  ;
  1.  I +LRXDPF=67,$G(LRXDFN) D  Q
  1.  . S DFN=LRXDFN
  1.  . D UPDATE
  1.  ;
  1.  I LRSD("RIEN"),'$D(^LRT(67,+LRSD("RIEN"),0))#2 S LRSD("ERROR")="16^Missing pointed to LRT(67,"_LRSD("RIEN")_",0)" Q
  1.  ;
  1.  I LRSD("RIEN") D  Q
  1.  . I +LRXDPF=2,LRXDFN'=$G(^LRT(67,LRSD("RIEN"),"DPT")) S LREND=1,LRSD("ERROR")="10^Database Degrade "
  1.  . I '$G(LREND) D UPDATE
  1.  ;
  1.  I 'LRSD("RIEN") S LRSD("RIEN")=$O(^LRT(67,"C",SSN,0)) I LRSD("RIEN"),$O(^(LRSD("RIEN"))) D DUP Q
  1.  ;
  1.  I LRSD("RIEN") D  Q
  1.  . I '$D(^LRT(67,LRSD("RIEN"),0)) D  Q
  1.  . . K ^LRT(67,"C",SSN,LRSD("RIEN"))
  1.  . . S LRSD("ERROR")="13^Missing Zero Node for "_LRSD("RIEN")_" SSN X Ref Entry Removed"
  1.  . D LINK Q:$G(LREND)
  1.  . I +LRXDPF=2 S X="^"_$P(LRXDPF,"^",2)_LRXDFN_",""LRT"")",@X=LRSD("RIEN")
  1.  ;
  1.  I 'LRSD("RIEN") D SET G ERR:LREND
  1.  S DFN=LRSD("RIEN"),LRDPF="67^LRT(67,"
  1. END ;
  1.  Q
  1.  ;
  1.  ;
  1. SET ;Create new entry in ^LRT(67
  1.  I +$G(LRXDPF)'=67,LRXDFN<1 D  Q
  1.  . S LREND=1,LRSD("ERROR")="14^No LRXDFN defined"
  1.  ;
  1. SET1 N DIC,DIE,DA,Y
  1.  L +^LRT(67,0):999
  1.  S DIC(0)="L",DLAYGO=67
  1.  S X=PNM,DIC="^LRT(67,"
  1.  S DIC("DR")=".01////"_PNM_";.02////"_SEX_";.03////"_DOB_";.09////"_SSN
  1.  I $G(LRSD("RACE"))'="" D RACE
  1.  S:+LRXDPF=2 DIC("DR")=DIC("DR")_";2////"_LRXDFN
  1.  K DD,DO
  1.  D FILE^DICN K DLAYGO
  1.  L -^LRT(67,0)
  1.  I Y<1 S LREND=1,LRSB("ERROR")="11^Failure attempting to add patient to LRT(67)",LRDFN=-1 Q
  1.  S LRSD("RIEN")=+Y S:+LRXDPF=2 ^DPT(LRXDFN,"LRT")=LRSD("RIEN")
  1.  S (DFN,LRSD("RIEN"))=+Y S LRSD("ERROR")=""
  1.  Q
  1.  ;
  1.  ;
  1.  N DA,DIC,DIE,DR
  1.  S (DFN,DA)=LRSD("RIEN") L +^LRT(67,DA)
  1.  S DIC(0)="LMN",DIE="^LRT(67,"
  1.  S DR=".01////"_PNM_";.02////"_SEX_";.03////"_DOB_";.09////"_SSN
  1.  I $G(LRSD("RACE"))'="" D RACE
  1.  S:+LRXDPF=2 DR=DR_";2////"_LRXDFN
  1.  S DIC=DIE D ^DIE S LREND=+$G(Y) L -^LRT(67,LRSD("RIEN"))
  1.  I LREND S DFN=-1,LRSD("ERROR")="17^ Unable to link "_LRSD("RIEN") Q
  1.  Q
  1.  ;
  1.  ;
  1. UPDATE ; Store updated demographics
  1.  N DA,DR,DIE,DIC,RACE
  1.  S (DFN,DA)=LRSD("RIEN")
  1.  S DIE="^LRT(67,"
  1.  S DR=".01////"_PNM_";.02////"_SEX_";.03////"_DOB_";.09////"_SSN
  1.  I $G(LRSD("RACE"))'="" D RACE
  1.  D ^DIE S LREND=+$G(Y)
  1.  I LREND S DFN=-1,LRSD("ERROR")="18^Unable to update demographics" Q
  1.  Q
  1.  ;
  1.  ;
  1. ERR1 W !?5,"Error1 ",!
  1.  Q
  1.  ;
  1. ERR W !?5,"Error ",!
  1.  Q
  1.  ;
  1.  ;
  1. DUP ;
  1.  S LRSD("ERROR")="15^Duplicate "_SSN_" SSN nunbers in LRT(67 ",LREND=1
  1.  W !?5,$P(LRSD("ERROR"),U,2)
  1.  Q
  1.  ;
  1.  ;
  1. KEYIN ;
  1.  S LRSD("ERROR")="16^Error During Manual Patient Entry"
  1.  W !!?30,"Manual Referral Patient Entry",!!
  1.  K DIR
  1.  S DIR(0)="F^9:12^K:X?1""-""!(X'?1N.N)!(X?1"" "") X I $D(X),$D(^LRT(67,""C"",X)) W !!?15,X,""  Already Exist"" K X"
  1.  S DIR("A")="Patient ID (SSN)",DIR("?")="Enter New Patient ID Nunber "
  1.  S DIR("?",1)="9-12 Number string '-' character or duplicates are Not allowed"
  1.  D RDDIR Q:LREND
  1.  S (LRSD("SSN"),SSN)=Y,Y=0
  1.  K DIR S DIR(0)="67,.01",DIR("A")="Patient Name"
  1.  D RDDIR Q:LREND  S (LRSD("PNM"),PNM)=Y
  1.  ;
  1.  K DIR S DIR(0)="67,.02" D RDDIR Q:LREND  S (LRSD("SEX"),SEX)=Y
  1.  K DIR S DIR(0)="67,.03" D RDDIR Q:LREND  S (LRSD("DOB"),DOB)=Y
  1.  S (LRXDPF,LRSD("LRXDPF"))="67^LRT(67," D SET1
  1.  Q
  1.  ;
  1.  ;
  1. RDDIR ;
  1.  S LREND=0
  1.  D ^DIR
  1.  S:$D(DUOUT)!($D(DTOUT)) LREND=1 K DIR
  1.  S:Y="" LREND=1
  1.  Q
  1.  ;
  1.  ;
  1. RACE ; Resolve race pointer
  1.  N RACE
  1.  S RACE=""
  1.  I $P(LRSD("RACE"),":",3)="" S RACE=$$CODE2PTR^DGUTL4(+LRSD("RACE"),1,1)
  1.  I $P(LRSD("RACE"),":",3)="HL70005" S RACE=$$CODE2PTR^DGUTL4($P($P(LRSD("RACE"),":"),"-",1,2),1,2)
  1.  I RACE>0 D
  1.  . I $D(DR) S DR=DR_";.06////"_RACE Q
  1.  . I $D(DIC("DR")) S DIC("DR")=DIC("DR")_";.06////"_RACE
  1.  Q