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

AUPNLKID.m

Go to the documentation of this file. 
  1. AUPNLKID ; IHS/CMI/LAB - IHS IDENTIFIERS FOR FILE 2 ; [ 05/09/2003  8:01 AM ]
  1.  ;;99.1;IHS DICTIONARIES (PATIENT);**5,9,10,17,18**;JUN 13, 2003;Build 9
  1.  ;IHS/OIT/LJF 07/21/2006 PATCH 17 hide DOB and SSN if patient is marked as sensitive
  1.  ;
  1. START ; EXTERNAL ENTRY POINT - 
  1.  ;W:$X>45 !
  1.  ;beginning Y2K - display 4 digit year identifier
  1.  ;D:$X>45 EN^DDIOL("","","!") ;Y2000 commented out for 4 digit display of DOB
  1.  D:$X>43 EN^DDIOL("","","!") ;Y2000
  1.  ; VALUE OF THE NAKED INDICATOR TO BE PROVIDED BY CALLING ROUTINE
  1.  ;I $D(DIQUIET) S ^TMP("DILIST",$J,"IHS",DICOUNT)=$P(^(0),U,2)_" "_$E($P(^(0),U,3),4,5)_"-"_$E($P(^(0),U,3),6,7)_"-"_$E($P(^(0),U,3),2,3)_" "_$J($P(^(0),U,9),9) ;IHS/ANMC/LJF 8/7/97 added for Kernel Broker calls-see ^XWBFM ;Y2000
  1.  ;
  1.  ;IHS/OIT/LJF 07/21/2006 hide DOB and SSN if sensitive patient PATCH 17
  1.  ;I $D(DIQUIET) S ^TMP("DILIST",$J,"IHS",DICOUNT)=$P(^(0),U,2)_" "_$E($P(^(0),U,3),4,5)_"-"_$E($P(^(0),U,3),6,7)_"-"_(1700+$E($P(^(0),U,3),1,3))_" "_$J($P(^(0),U,9),9) ;Y2000
  1.  ;IHS/CMI/LAB 10/03/2007, only display last 4 of SSN
  1.  ;I $D(DIQUIET),$L($T(SCREEN^DPTLK1)) S ^TMP("DILIST",$J,"IHS",DICOUNT)=$P(^(0),U,2)_" "_$S($$SCREEN^DPTLK1(Y):" ** SENSITIVE **    ",1:$E($P(^DPT(Y,0),U,3),4,5)_"-"_$E($P(^(0),U,3),6,7)_"-"_(1700+$E($P(^(0),U,3),1,3))_" "_$J($P(^(0),U,9),9))
  1.  ;E  I $D(DIQUIET) S ^TMP("DILIST",$J,"IHS",DICOUNT)=$P(^(0),U,2)_" "_$E($P(^(0),U,3),4,5)_"-"_$E($P(^(0),U,3),6,7)_"-"_(1700+$E($P(^(0),U,3),1,3))_" "_$J($P(^(0),U,9),9) ;Y2000
  1.  I $D(DIQUIET),$L($T(SCREEN^DPTLK1)) D  I 1
  1.  .S ^TMP("DILIST",$J,"IHS",DICOUNT)=$P(^(0),U,2)_" "_$S($$SCREEN^DPTLK1(Y):" ** SENSITIVE **    ",1:$E($P(^DPT(Y,0),U,3),4,5)_"-"_$E($P(^(0),U,3),6,7)_"-"_(1700+$E($P(^(0),U,3),1,3))_" "_$$SSN())
  1.  E  I $D(DIQUIET) D
  1.  .S ^TMP("DILIST",$J,"IHS",DICOUNT)=$P(^(0),U,2)_" "_$E($P(^(0),U,3),4,5)_"-"_$E($P(^(0),U,3),6,7)_"-"_(1700+$E($P(^(0),U,3),1,3))_" "_$$SSN ;Y2000
  1.  ;K AUPNA I '$D(DIQUIET) NEW % S %=$P(^(0),U,2)_" "_$E($P(^(0),U,3),4,5)_"-"_$E($P(^(0),U,3),6,7)_"-"_$E($P(^(0),U,3),2,3)_" "_$J($P(^(0),U,9),9) S AUPNA(1)=%,AUPNA(1,"F")="?45" ;Y2000 commented out and replaced with line below
  1.  ;K AUPNA I '$D(DIQUIET) NEW % S %=$P(^(0),U,2)_" "_$E($P(^(0),U,3),4,5)_"-"_$E($P(^(0),U,3),6,7)_"-"_(1700+$E($P(^(0),U,3),1,3))_" "_$J($P(^(0),U,9),9) S AUPNA(1)=%,AUPNA(1,"F")="?43" ;Y2000 - display 4 digit year
  1.  K AUPNA
  1.  I '$D(DIQUIET),$L($T(SCREEN^DPTLK1)) D
  1.  . ;IHS/CMI/LAB 10/03/2007 display only last 4 of SSN
  1.  . ;NEW % S %=$P(^(0),U,2)_" "_$S($$SCREEN^DPTLK1(Y):" ** SENSITIVE **    ",1:$E($P(^DPT(Y,0),U,3),4,5)_"-"_$E($P(^(0),U,3),6,7)_"-"_(1700+$E($P(^(0),U,3),1,3))_" "_$J($P(^(0),U,9),9)) S AUPNA(1)=%,AUPNA(1,"F")="?43"
  1.  . NEW % S %=$P(^(0),U,2)_" "_$S($$SCREEN^DPTLK1(Y):" ** SENSITIVE **    ",1:$E($P(^DPT(Y,0),U,3),4,5)_"-"_$E($P(^(0),U,3),6,7)_"-"_(1700+$E($P(^(0),U,3),1,3))_" "_$$SSN) S AUPNA(1)=%,AUPNA(1,"F")="?43"
  1.  ;E  K AUPNA I '$D(DIQUIET) NEW % S %=$P(^(0),U,2)_" "_$E($P(^(0),U,3),4,5)_"-"_$E($P(^(0),U,3),6,7)_"-"_(1700+$E($P(^(0),U,3),1,3))_" "_$J($E($P(^(0),U,9),6,9),9) S AUPNA(1)=%,AUPNA(1,"F")="?43" ;Y2000 - display 4 digit year
  1.  E  K AUPNA I '$D(DIQUIET) NEW % S %=$P(^(0),U,2)_" "_$E($P(^(0),U,3),4,5)_"-"_$E($P(^(0),U,3),6,7)_"-"_(1700+$E($P(^(0),U,3),1,3))_" "_$$SSN S AUPNA(1)=%,AUPNA(1,"F")="?43" ;Y2000 - display 4 digit year
  1.  ;IHS/OIT/LJF 07/21/2006 end of PATCH 17 mod
  1.  ;
  1.  ;end Y2K for display of  4 digit DOB
  1.  I '$D(DIQUIET) S AUPNA(1)=$$CWAD(Y)_AUPNA(1),AUPNA(1,"F")="?37"
  1.  I $D(DUZ(2))#2,DUZ(2),'$D(DIQUIET) I $D(^AUPNPAT(Y,41,DUZ(2),0)) NEW % S %=" "_$J($P(^AUTTLOC(DUZ(2),0),U,7),4)_" "_$P(^AUPNPAT(Y,41,DUZ(2),0),U,2) S AUPNA(1)=AUPNA(1)_" "_%
  1.  I $D(DUZ(2))#2,'DUZ(2),$D(^AUPNPAT(Y,41)) D CHARTS
  1.  S:$D(DDS) DDSID=1 D EN^DDIOL(.AUPNA) K AUPNA,DDSID
  1.  W @("$E("_DIC_"Y,0),0)") ; reset the naked
  1.  Q
  1.  ;
  1. CHARTS ;
  1.  S AUPNLKF=0
  1.  NEW C S C=1 F AUPNLKI=0:1 S AUPNLKF=$O(^AUPNPAT(Y,41,AUPNLKF)) Q:AUPNLKF'=+AUPNLKF  D
  1.  .I AUPNLKI S C=C+1
  1.  .;beginning Y2K display 4 digit DOB spacing
  1.  .;NEW % S %=" "_$J($P(^AUTTLOC(AUPNLKF,0),U,7),4)_" "_$P(^AUPNPAT(Y,41,AUPNLKF,0),U,2)_$S($P(^(0),U,3)="":"",1:"("_$P(^(0),U,5)_")");Y2000 commented out for 4 digit year display
  1.  .NEW % S %=$J($P(^AUTTLOC(AUPNLKF,0),U,7),4)_" "_$P(^AUPNPAT(Y,41,AUPNLKF,0),U,2)_$S($P(^(0),U,3)="":"",1:"("_$P(^(0),U,5)_")") ;Y2000 
  1.  .;end Y2K
  1.  .S:'$D(AUPNA(C)) AUPNA(C)=""
  1.  .S AUPNA(C)=AUPNA(C)_" "_% S:'$D(AUPNA(C,"F")) AUPNA(C,"F")="!?65"
  1.  K AUPNLKF,AUPNLKI
  1.  Q
  1.  ;
  1. IHSDUPE ; EXTERNAL ENTRY PONT - FOLLOW MERGE CHAIN
  1.  ; VALUE OF THE NAKED INDICATOR TO BE PROVIDED BY CALLING ROUTINE
  1.  F AUPLKL=0:0 Q:'$P(^(0),U,19)  S AUPMAP=$P(^(0),U,19) D EN^DDIOL("<Merged to "_$P(^DPT(AUPMAP,0),U,1)_">","","!?10") ; Will abort if no ^DPT entry
  1.  K AUPLKL
  1.  I $D(AUPMAP) S AUPMAPY=Y,Y=AUPMAP K AUPMAP
  1.  W @("$E("_DIC_"Y,0),0)") ; reset the naked
  1.  Q
  1.  ;
  1. CWAD(Y) ; -- returns cwad initials;IHS/ANMC/LJF 5/26/98
  1.  NEW X,DFN,GMRPCWAD
  1.  S X="GMRPNOR1" X ^%ZOSF("TEST") I '$T Q "   "
  1.  S X=$$CWAD^GMRPNOR1(+Y) I '$L(X) Q "   "
  1.  S X="<"_X_">",X=$E(X_"   ",1,7)
  1.  Q X
  1. SSN() ;
  1.  Q $S($L($P(^(0),U,9))=9:$J("XXX-XX-"_$E($P(^(0),U,9),6,9),11),1:$J($P(^(0),U,9),11))
  1.  ;