| 1 | AUPNLKID ; 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 | ;
|
|---|
| 4 | START ; 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"
|
|---|
| 13 | NOTALL 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)_" "_%
|
|---|
| 14 | ALL 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 | ;
|
|---|
| 19 | CHARTS ;
|
|---|
| 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 | ;
|
|---|
| 33 | IHSDUPE ; 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 | ;
|
|---|
| 41 | CWAD(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
|
|---|
