source: WorldVistAEHR/trunk/r/IHS_ROUTINES-AUP/AUPNLKID.m@ 1005

Last change on this file since 1005 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.5 KB
Line 
1AUPNLKID ; IHS/CMI/LAB - IHS IDENTIFIERS FOR FILE 2 ;12/26/06 10:53
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**167**;Aug 12, 1996;Build 22
3 ;
4START ; EXTERNAL ENTRY POINT -
5 D:$X>43 EN^DDIOL("","","!") ;Y2000
6 ; VALUE OF THE NAKED INDICATOR TO BE PROVIDED BY CALLING ROUTINE
7 ;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
8 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
9 ;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
10 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
11 ;end Y2K for display of 4 digit DOB
12 I '$D(DIQUIET) S AUPNA(1)=$$CWAD(Y)_AUPNA(1),AUPNA(1,"F")="?37"
13NOTALL I '$G(AUPNLK("ALL")),$G(DUZ(2)),'$D(DIQUIET),$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)_" "_%
14ALL I $G(AUPNLK("ALL")),$D(^AUPNPAT(Y,41)) D CHARTS
15 S:$D(DDS) DDSID=1 D EN^DDIOL(.AUPNA) K AUPNA,DDSID
16 I @(DIC_"Y,0)") ; reset the naked
17 Q
18 ;
19CHARTS ;
20 N C,%,TAB S AUPNLKF=0
21 S C=1 F AUPNLKI=0:1 S AUPNLKF=$O(^AUPNPAT(Y,41,AUPNLKF)) Q:AUPNLKF'=+AUPNLKF D
22 .I AUPNLKI S C=C+1
23 .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)_")")
24 .S TAB=66 I $L($G(AUPNA(C)))+$L(%)>42 S C=C+1,TAB=79-$L(%)
25 .S:'$D(AUPNA(C)) AUPNA(C)=""
26 .S AUPNA(C)=AUPNA(C)_" "_% S:'$D(AUPNA(C,"F")) AUPNA(C,"F")="!?"_TAB
27 K AUPNLKF,AUPNLKI
28 Q
29 ;
30 ;
31 ;
32 ;
33IHSDUPE ; EXTERNAL ENTRY PONT - FOLLOW MERGE CHAIN
34 ; VALUE OF THE NAKED INDICATOR TO BE PROVIDED BY CALLING ROUTINE
35 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
36 K AUPLKL
37 I $D(AUPMAP) S AUPMAPY=Y,Y=AUPMAP K AUPMAP
38 I @(DIC_"Y,0)") ; reset the naked
39 Q
40 ;
41CWAD(Y) ; -- returns cwad initials;IHS/ANMC/LJF 5/26/98
42 NEW X,DFN,GMRPCWAD
43 S X="GMRPNOR1" X ^%ZOSF("TEST") I '$T Q " "
44 S X=$$CWAD^GMRPNOR1(+Y) I '$L(X) Q " "
45 S X="<"_X_">",X=$E(X_" ",1,7)
46 Q X
Note: See TracBrowser for help on using the repository browser.