AZAXCADU ;IHS/PHXAO/AEF - CAD/STATIN STUDY DATA EXTRACT UTILITY SUBROUTINES
;;1.0;ANNE'S SPECIAL ROUTINES;;MAR 23, 2004
;
DESC ;---- PROGRAM DESCRIPTION
;;
;; This routine contains utility subroutines used by the
;; AZAXCAD CAD/STATIN STUDY DATA EXTRACT routine.
;;
;;$$END
;
Q
;
AGE(X) ;
;----- RETURN PATIENT'S AGE
;
; X = PATIENT IEN
;
N X1,X2,Y
S Y=""
I $G(X) D
. S X2=$P($G(^DPT(X,0)),U,3)
. I X2 D
. . S X1=DT
. . D ^%DTC
. . S Y=X\365.25
Q Y
;
DRUG(X) ;
;----- RETURN DRUG NAME
;
; X = DRUG IEN
;
N Y
S Y=""
I $G(X) S Y=$P($G(^PSDRUG(X,0)),U)
Q Y
;
FNAME(X) ;
;----- RETURN FILE NAME
;
; X = DATA TYPE, I.E., DRUGS OR ICDS
;
N Y
S Y=""
I $G(X)]"" D
. S Y="AZAX"_X_$$SITE_".TXT"
Q Y
FORMAT(X) ;
;----- FORMAT "^" DELIMITED DATA STRING INTO COMMA DELIMITED STRING
;
; INPUT:
; X = DATA STRING IN "^" DELIMITED FIELD FORMAT,
; I.E., FIELD1^FIELD2^FIELD3^FIELD4
;
; OUTPUT:
; Y = DATA STRING IN QUOTED DATA/COMMA DELIMITED FORMAT,
; I.E., "FIELD1","FIELD2","FIELD3","FIELD4"
;
N I,Y,Z
S Y=""
I $G(X)]"" D
. F I=1:1:$L(X,U) D
. . S Z=$P(X,U,I)
. . S Y=Y_""""_Z_""""_","
. S Y=$E(Y,1,$L(Y)-1)
Q Y
;
HFS(AZAXPATH,AZAXFILE,%FILE,AZAXOUT) ;
;----- CREATE AND OPEN DATA FILE
;
; INPUT:
; AZAXFILE = THE FILENAME TO CREATE AND OPEN
; AZAXPATH = THE UNIX OR WINDOWS DIRECTORY PATH NAME TO PUT THE FILE
;
; OUTPUT:
; %FILE = DEVICE NUMBER OF THE FILE
; AZAXOUT = QUIT INDICATOR
;
N POP,X,Y,ZISH1,ZISH2,ZISH3,ZISH4
;
S %FILE=""
S AZAXOUT=0
S ZISH1="FILE"
S ZISH2=AZAXPATH
S ZISH3=AZAXFILE
S ZISH4="W"
;
D OPEN^%ZISH(ZISH1,ZISH2,ZISH3,ZISH4)
;
I POP D Q
. W "CANNOT OPEN FILE "_ZISH2_ZISH3
. S AZAXOUT=1
S %FILE=IO
Q
ICD(X) ;
;----- RESOLVE ICD DX CODE POINTER
;
; X = INTERNAL ICD DIAGNOSIS CODE
;
N Y
S Y=""
I $G(X) S Y=$P($G(^ICD9(X,0)),U)
Q Y
;
LOC(X) ;
;----- RETURN LOCATION OF ENCOUNTER FROM VISIT FILE
;
; X = VISIT IEN
;
N Y
S Y=""
I $G(X) S Y=$P($G(^AUPNVSIT(X,0)),U,6)
Q Y
;
LOCN(X) ;
;----- RETURN LOCATION NAME
;
; X = LOCATION IEN
;
N Y
S Y=""
I $G(X) D
. S Y=$P($G(^AUTTLOC(X,0)),U)
. I Y S Y=$P($G(^DIC(4,Y,0)),U)
Q Y
;
LOCP(X) ;
;----- RETURN LOCATION OF ENCOUNTER FROM INSIDE PRESCRIPTION FILE
;
; X = PRESCRIPTION IEN
;
N Y,Z
S Y=""
I $G(X) D
. S Z=$P($G(^PSRX(X,999999911)),U)
. I Z S Y=$$LOCVM(Z)
Q Y
;
LOCR(D0,D1) ;
;----- RETURN LOCATION OF ENCOUNTER FROM INSIDE REFILL SUBFILE OF
; PRESCRIPTION FILE
;
; D0 = PRESCRIPTION IEN
; D1 = REFILL IEN
;
N Y
S Y=""
I $G(D0),$G(D1) D
. S Z=$P($G(^PSRX(D0,1,D1,999999911)),U)
. I Z S Y=$$LOCVM(Z)
Q Y
;
LOCVM(X) ;
;----- RETURN LOCATION OF ENCOUNTER FROM INSIDE V MEDICATION FILE
;
; X = V MEDICATION IEN
;
N Y,Z
S Y=""
I $G(X) D
. S Z=$P($G(^AUPNVMED(X,0)),U,3)
. I Z S Y=$P($G(^AUPNVSIT(Z,0)),U,6)
Q Y
;
NDC(X) ;
;----- RETURN NDC CODE
;
; X = DRUG IEN
;
N Y
S Y=""
I $G(X) S Y=$P($G(^PSDRUG(X,2)),U,4)
Q Y
PATH(X) ;
;
; X = RPMS SITE IEN
;
N Y
S Y=""
;
I $G(X) D
. ;I X=2906 S Y="C:\inetpub\ftproot\pub\" ;PARKER ON phxed
. I X=3018 S Y="E:\pub\" ;WHITERIVER
. I X=2898 S Y="c:\inetpub\ftproot\pub\" ;ELKO
. I X=2869 S Y="c:\inetpub\ftproot\pub\" ;FT DUCHESNE
. I X=3050 S Y="d:\pub\" ;FT YUMA
. I X=2872 S Y="/usr/spool/uucppublic/" ;HOPI
. I X=7150 S Y="d:\pub\" ;OWYHEE
. I X=2906 S Y="/usr/spool/uucppublic/" ;PARKER
. I X=2955 S Y="/usr/spool/uucppublic/" ;SACATON (IHS)
. I X=6283 S Y="/usr/spool/uucppublic/" ;SACATON (638)
. I X=2967 S Y="d:\pub\" ;SAN CARLOS (IHS)
. I X=6622 S Y="d:\pub\" ;SAN CARLOS (638)
. I X=3000 S Y="/usr/spool/uucppublic/" ;SCHURZ
. I X=5621 S Y="/usr/spool/uucppublic/" ;SCHURZ (WALKER RIVER)
. I X=3018 S Y="e:\pub\" ;WHITERIVER
. I X=6600 S Y="c:\inetpub\ftproot\pub\" ;CEDAR CITY (FT DUCHESNE)
. I X=3245 S Y="/usr/spool/uucppublic/" ;WASHOE (SCHURZ)
. I X=3246 S Y="/usr/spool/uucppublic/" ;RENO/SPARKS (SCHURZ)
. I X=3008 S Y="/usr/spool/uucppublic/" ;FALLON (SCHURZ)
. I X=2917 S Y="d:\pub\" ;PIMC
;
Q Y
;
PICD(X) ;
;----- RESOLVE ICD PROCEDURE CODE POINTER
;
; X = INTERNAL ICD PROCEDURE CODE
;
N Y
S Y=""
I $G(X) S Y=$P($G(^ICD0(X,0)),U)
Q Y
;
SCAT(X) ;
;----- RETURN EXTERNAL SERVICE CATEGORY
;
; X = INTERNAL SERVICE CATETORY
;
N Y,Z
S Y=""
I $G(X)]"" D
. S Z=$P($G(^DD(9000010,.07,0)),U,3)
. S Z=$P(Z,X_":",2)
. S Z=$P(Z,";")
. S Y=Z
Q Y
;
SCATP(X) ;
;----- RETURN EXTERNAL SERVICE CATEGORY FROM INSIDE PRESCRIPTION FILE
;
; X = PRESCRIPTION IEN
;
N Y,Z
S Y=""
I $G(X) D
. S Z=$P($G(^PSRX(X,999999911)),U)
. I Z S Y=$$SCATVM(Z)
Q Y
;
SCATR(D0,D1) ;
;----- RETURN EXERNAL SERVICE CATEGORY FROM INSIDE REFILL SUBFILE OF
; PRESCRIPTION FILE
;
; D0 = PRESCRIPTION IEN
; D1 = REFILL IEN
;
N Y,Z
S Y=""
I $G(D0),$G(D1) D
. S Z=$P($G(^PSRX(D0,1,D1,999999911)),U)
. I Z S Y=$$SCATVM(Z)
Q Y
;
SCATV(X) ;
;----- RETURN SERVICE CATEGORY FROM INSIDE VISIT FILE
;
; X = VISIT IEN
;
S Y=""
I $G(X) S Y=$P($G(^AUPNVSIT(X,0)),U,7)
Q Y
;
SCATVM(X) ;
;----- RETURN EXTERNAL SERVICE CATEGORY FROM INSIDE V MEDICATION FILE
;
; X = V MEDICATION FILE IEN
;
N Y,Z
S Y=""
I $G(X) D
. S Z=$P($G(^AUPNVMED(X,0)),U,3)
. I Z S Z=$P($G(^AUPNVSIT(Z,0)),U,7)
. I Z]"" S Z=$$SCAT(Z)
. I Z]"" S Y=Z
Q Z
;
SEX(X) ;
;----- RETURN PATIENT'S SEX
;
; X = PATIENT IEN
;
N Y
S Y=""
I $G(X) S Y=$P($G(^DPT(X,0)),U,2)
Q Y
;
SITE() ;
;----- RETURNS LOCATION IEN
;
Q $P($G(^AUTTSITE(1,0)),U)
;
SLDATE(X) ;
;----- RETURNS DATE IN MM/DD/YYYY FORMAT
;
; X = INTERNAL FILEMANAGER DATE IN YYYMMDD FORMAT
;
N Y
S Y=""
I $G(X) D
. Q:$L(X)'=7
. S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_($E(X,1,3)+1700)
Q Y
;
UID(X) ;
;----- CALCULATE UNIQUE PATIENT ID USING LOCATION IEN AND DFN
; Returns a 13 digit unique patient ID where:
; 1st digit = 1 (so that number never starts with zero)
; 2-5 digits = 4 character location IEN (padded with zeros)
; 6-13 digits = 8 character DFN (padded with zeros)
;
; INPUT:
; X = DFN (PATIENT IEN)
;
N S,Y
S Y=""
I $G(X) D
. S X=$E("00000000",1,8-$L(X))_X
. S S=$$SITE
. S S=$E("0000",1,4-$L(S))_S
. S Y=1_S_X
Q Y
;
VISDT(X) ;
;----- RETURN VISIT DATE
;
; X = VISIT IEN
;
N Y
S Y=""
I $G(X) S Y=$P($G(^AUPNVSIT(X,0)),U)
Q Y
AZAXCADU ;IHS/PHXAO/AEF - CAD/STATIN STUDY DATA EXTRACT UTILITY SUBROUTINES
+1 ;;1.0;ANNE'S SPECIAL ROUTINES;;MAR 23, 2004
+2 ;
DESC ;---- PROGRAM DESCRIPTION
+1 ;;
+2 ;; This routine contains utility subroutines used by the
+3 ;; AZAXCAD CAD/STATIN STUDY DATA EXTRACT routine.
+4 ;;
+5 ;;$$END
+6 ;
+7 QUIT
+8 ;
AGE(X) ;
+1 ;----- RETURN PATIENT'S AGE
+2 ;
+3 ; X = PATIENT IEN
+4 ;
+5 NEW X1,X2,Y
+6 SET Y=""
+7 IF $GET(X)
Begin DoDot:1
+8 SET X2=$PIECE($GET(^DPT(X,0)),U,3)
+9 IF X2
Begin DoDot:2
+10 SET X1=DT
+11 DO ^%DTC
+12 SET Y=X\365.25
End DoDot:2
End DoDot:1
+13 QUIT Y
+14 ;
DRUG(X) ;
+1 ;----- RETURN DRUG NAME
+2 ;
+3 ; X = DRUG IEN
+4 ;
+5 NEW Y
+6 SET Y=""
+7 IF $GET(X)
SET Y=$PIECE($GET(^PSDRUG(X,0)),U)
+8 QUIT Y
+9 ;
FNAME(X) ;
+1 ;----- RETURN FILE NAME
+2 ;
+3 ; X = DATA TYPE, I.E., DRUGS OR ICDS
+4 ;
+5 NEW Y
+6 SET Y=""
+7 IF $GET(X)]""
Begin DoDot:1
+8 SET Y="AZAX"_X_$$SITE_".TXT"
End DoDot:1
+9 QUIT Y
FORMAT(X) ;
+1 ;----- FORMAT "^" DELIMITED DATA STRING INTO COMMA DELIMITED STRING
+2 ;
+3 ; INPUT:
+4 ; X = DATA STRING IN "^" DELIMITED FIELD FORMAT,
+5 ; I.E., FIELD1^FIELD2^FIELD3^FIELD4
+6 ;
+7 ; OUTPUT:
+8 ; Y = DATA STRING IN QUOTED DATA/COMMA DELIMITED FORMAT,
+9 ; I.E., "FIELD1","FIELD2","FIELD3","FIELD4"
+10 ;
+11 NEW I,Y,Z
+12 SET Y=""
+13 IF $GET(X)]""
Begin DoDot:1
+14 FOR I=1:1:$LENGTH(X,U)
Begin DoDot:2
+15 SET Z=$PIECE(X,U,I)
+16 SET Y=Y_""""_Z_""""_","
End DoDot:2
+17 SET Y=$EXTRACT(Y,1,$LENGTH(Y)-1)
End DoDot:1
+18 QUIT Y
+19 ;
HFS(AZAXPATH,AZAXFILE,%FILE,AZAXOUT) ;
+1 ;----- CREATE AND OPEN DATA FILE
+2 ;
+3 ; INPUT:
+4 ; AZAXFILE = THE FILENAME TO CREATE AND OPEN
+5 ; AZAXPATH = THE UNIX OR WINDOWS DIRECTORY PATH NAME TO PUT THE FILE
+6 ;
+7 ; OUTPUT:
+8 ; %FILE = DEVICE NUMBER OF THE FILE
+9 ; AZAXOUT = QUIT INDICATOR
+10 ;
+11 NEW POP,X,Y,ZISH1,ZISH2,ZISH3,ZISH4
+12 ;
+13 SET %FILE=""
+14 SET AZAXOUT=0
+15 SET ZISH1="FILE"
+16 SET ZISH2=AZAXPATH
+17 SET ZISH3=AZAXFILE
+18 SET ZISH4="W"
+19 ;
+20 DO OPEN^%ZISH(ZISH1,ZISH2,ZISH3,ZISH4)
+21 ;
+22 IF POP
Begin DoDot:1
+23 WRITE "CANNOT OPEN FILE "_ZISH2_ZISH3
+24 SET AZAXOUT=1
End DoDot:1
QUIT
+25 SET %FILE=IO
+26 QUIT
ICD(X) ;
+1 ;----- RESOLVE ICD DX CODE POINTER
+2 ;
+3 ; X = INTERNAL ICD DIAGNOSIS CODE
+4 ;
+5 NEW Y
+6 SET Y=""
+7 IF $GET(X)
SET Y=$PIECE($GET(^ICD9(X,0)),U)
+8 QUIT Y
+9 ;
LOC(X) ;
+1 ;----- RETURN LOCATION OF ENCOUNTER FROM VISIT FILE
+2 ;
+3 ; X = VISIT IEN
+4 ;
+5 NEW Y
+6 SET Y=""
+7 IF $GET(X)
SET Y=$PIECE($GET(^AUPNVSIT(X,0)),U,6)
+8 QUIT Y
+9 ;
LOCN(X) ;
+1 ;----- RETURN LOCATION NAME
+2 ;
+3 ; X = LOCATION IEN
+4 ;
+5 NEW Y
+6 SET Y=""
+7 IF $GET(X)
Begin DoDot:1
+8 SET Y=$PIECE($GET(^AUTTLOC(X,0)),U)
+9 IF Y
SET Y=$PIECE($GET(^DIC(4,Y,0)),U)
End DoDot:1
+10 QUIT Y
+11 ;
LOCP(X) ;
+1 ;----- RETURN LOCATION OF ENCOUNTER FROM INSIDE PRESCRIPTION FILE
+2 ;
+3 ; X = PRESCRIPTION IEN
+4 ;
+5 NEW Y,Z
+6 SET Y=""
+7 IF $GET(X)
Begin DoDot:1
+8 SET Z=$PIECE($GET(^PSRX(X,999999911)),U)
+9 IF Z
SET Y=$$LOCVM(Z)
End DoDot:1
+10 QUIT Y
+11 ;
LOCR(D0,D1) ;
+1 ;----- RETURN LOCATION OF ENCOUNTER FROM INSIDE REFILL SUBFILE OF
+2 ; PRESCRIPTION FILE
+3 ;
+4 ; D0 = PRESCRIPTION IEN
+5 ; D1 = REFILL IEN
+6 ;
+7 NEW Y
+8 SET Y=""
+9 IF $GET(D0)
IF $GET(D1)
Begin DoDot:1
+10 SET Z=$PIECE($GET(^PSRX(D0,1,D1,999999911)),U)
+11 IF Z
SET Y=$$LOCVM(Z)
End DoDot:1
+12 QUIT Y
+13 ;
LOCVM(X) ;
+1 ;----- RETURN LOCATION OF ENCOUNTER FROM INSIDE V MEDICATION FILE
+2 ;
+3 ; X = V MEDICATION IEN
+4 ;
+5 NEW Y,Z
+6 SET Y=""
+7 IF $GET(X)
Begin DoDot:1
+8 SET Z=$PIECE($GET(^AUPNVMED(X,0)),U,3)
+9 IF Z
SET Y=$PIECE($GET(^AUPNVSIT(Z,0)),U,6)
End DoDot:1
+10 QUIT Y
+11 ;
NDC(X) ;
+1 ;----- RETURN NDC CODE
+2 ;
+3 ; X = DRUG IEN
+4 ;
+5 NEW Y
+6 SET Y=""
+7 IF $GET(X)
SET Y=$PIECE($GET(^PSDRUG(X,2)),U,4)
+8 QUIT Y
PATH(X) ;
+1 ;
+2 ; X = RPMS SITE IEN
+3 ;
+4 NEW Y
+5 SET Y=""
+6 ;
+7 IF $GET(X)
Begin DoDot:1
+8 ;I X=2906 S Y="C:\inetpub\ftproot\pub\" ;PARKER ON phxed
+9 ;WHITERIVER
IF X=3018
SET Y="E:\pub\"
+10 ;ELKO
IF X=2898
SET Y="c:\inetpub\ftproot\pub\"
+11 ;FT DUCHESNE
IF X=2869
SET Y="c:\inetpub\ftproot\pub\"
+12 ;FT YUMA
IF X=3050
SET Y="d:\pub\"
+13 ;HOPI
IF X=2872
SET Y="/usr/spool/uucppublic/"
+14 ;OWYHEE
IF X=7150
SET Y="d:\pub\"
+15 ;PARKER
IF X=2906
SET Y="/usr/spool/uucppublic/"
+16 ;SACATON (IHS)
IF X=2955
SET Y="/usr/spool/uucppublic/"
+17 ;SACATON (638)
IF X=6283
SET Y="/usr/spool/uucppublic/"
+18 ;SAN CARLOS (IHS)
IF X=2967
SET Y="d:\pub\"
+19 ;SAN CARLOS (638)
IF X=6622
SET Y="d:\pub\"
+20 ;SCHURZ
IF X=3000
SET Y="/usr/spool/uucppublic/"
+21 ;SCHURZ (WALKER RIVER)
IF X=5621
SET Y="/usr/spool/uucppublic/"
+22 ;WHITERIVER
IF X=3018
SET Y="e:\pub\"
+23 ;CEDAR CITY (FT DUCHESNE)
IF X=6600
SET Y="c:\inetpub\ftproot\pub\"
+24 ;WASHOE (SCHURZ)
IF X=3245
SET Y="/usr/spool/uucppublic/"
+25 ;RENO/SPARKS (SCHURZ)
IF X=3246
SET Y="/usr/spool/uucppublic/"
+26 ;FALLON (SCHURZ)
IF X=3008
SET Y="/usr/spool/uucppublic/"
+27 ;PIMC
IF X=2917
SET Y="d:\pub\"
End DoDot:1
+28 ;
+29 QUIT Y
+30 ;
PICD(X) ;
+1 ;----- RESOLVE ICD PROCEDURE CODE POINTER
+2 ;
+3 ; X = INTERNAL ICD PROCEDURE CODE
+4 ;
+5 NEW Y
+6 SET Y=""
+7 IF $GET(X)
SET Y=$PIECE($GET(^ICD0(X,0)),U)
+8 QUIT Y
+9 ;
SCAT(X) ;
+1 ;----- RETURN EXTERNAL SERVICE CATEGORY
+2 ;
+3 ; X = INTERNAL SERVICE CATETORY
+4 ;
+5 NEW Y,Z
+6 SET Y=""
+7 IF $GET(X)]""
Begin DoDot:1
+8 SET Z=$PIECE($GET(^DD(9000010,.07,0)),U,3)
+9 SET Z=$PIECE(Z,X_":",2)
+10 SET Z=$PIECE(Z,";")
+11 SET Y=Z
End DoDot:1
+12 QUIT Y
+13 ;
SCATP(X) ;
+1 ;----- RETURN EXTERNAL SERVICE CATEGORY FROM INSIDE PRESCRIPTION FILE
+2 ;
+3 ; X = PRESCRIPTION IEN
+4 ;
+5 NEW Y,Z
+6 SET Y=""
+7 IF $GET(X)
Begin DoDot:1
+8 SET Z=$PIECE($GET(^PSRX(X,999999911)),U)
+9 IF Z
SET Y=$$SCATVM(Z)
End DoDot:1
+10 QUIT Y
+11 ;
SCATR(D0,D1) ;
+1 ;----- RETURN EXERNAL SERVICE CATEGORY FROM INSIDE REFILL SUBFILE OF
+2 ; PRESCRIPTION FILE
+3 ;
+4 ; D0 = PRESCRIPTION IEN
+5 ; D1 = REFILL IEN
+6 ;
+7 NEW Y,Z
+8 SET Y=""
+9 IF $GET(D0)
IF $GET(D1)
Begin DoDot:1
+10 SET Z=$PIECE($GET(^PSRX(D0,1,D1,999999911)),U)
+11 IF Z
SET Y=$$SCATVM(Z)
End DoDot:1
+12 QUIT Y
+13 ;
SCATV(X) ;
+1 ;----- RETURN SERVICE CATEGORY FROM INSIDE VISIT FILE
+2 ;
+3 ; X = VISIT IEN
+4 ;
+5 SET Y=""
+6 IF $GET(X)
SET Y=$PIECE($GET(^AUPNVSIT(X,0)),U,7)
+7 QUIT Y
+8 ;
SCATVM(X) ;
+1 ;----- RETURN EXTERNAL SERVICE CATEGORY FROM INSIDE V MEDICATION FILE
+2 ;
+3 ; X = V MEDICATION FILE IEN
+4 ;
+5 NEW Y,Z
+6 SET Y=""
+7 IF $GET(X)
Begin DoDot:1
+8 SET Z=$PIECE($GET(^AUPNVMED(X,0)),U,3)
+9 IF Z
SET Z=$PIECE($GET(^AUPNVSIT(Z,0)),U,7)
+10 IF Z]""
SET Z=$$SCAT(Z)
+11 IF Z]""
SET Y=Z
End DoDot:1
+12 QUIT Z
+13 ;
SEX(X) ;
+1 ;----- RETURN PATIENT'S SEX
+2 ;
+3 ; X = PATIENT IEN
+4 ;
+5 NEW Y
+6 SET Y=""
+7 IF $GET(X)
SET Y=$PIECE($GET(^DPT(X,0)),U,2)
+8 QUIT Y
+9 ;
SITE() ;
+1 ;----- RETURNS LOCATION IEN
+2 ;
+3 QUIT $PIECE($GET(^AUTTSITE(1,0)),U)
+4 ;
SLDATE(X) ;
+1 ;----- RETURNS DATE IN MM/DD/YYYY FORMAT
+2 ;
+3 ; X = INTERNAL FILEMANAGER DATE IN YYYMMDD FORMAT
+4 ;
+5 NEW Y
+6 SET Y=""
+7 IF $GET(X)
Begin DoDot:1
+8 IF $LENGTH(X)'=7
QUIT
+9 SET Y=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_($EXTRACT(X,1,3)+1700)
End DoDot:1
+10 QUIT Y
+11 ;
UID(X) ;
+1 ;----- CALCULATE UNIQUE PATIENT ID USING LOCATION IEN AND DFN
+2 ; Returns a 13 digit unique patient ID where:
+3 ; 1st digit = 1 (so that number never starts with zero)
+4 ; 2-5 digits = 4 character location IEN (padded with zeros)
+5 ; 6-13 digits = 8 character DFN (padded with zeros)
+6 ;
+7 ; INPUT:
+8 ; X = DFN (PATIENT IEN)
+9 ;
+10 NEW S,Y
+11 SET Y=""
+12 IF $GET(X)
Begin DoDot:1
+13 SET X=$EXTRACT("00000000",1,8-$LENGTH(X))_X
+14 SET S=$$SITE
+15 SET S=$EXTRACT("0000",1,4-$LENGTH(S))_S
+16 SET Y=1_S_X
End DoDot:1
+17 QUIT Y
+18 ;
VISDT(X) ;
+1 ;----- RETURN VISIT DATE
+2 ;
+3 ; X = VISIT IEN
+4 ;
+5 NEW Y
+6 SET Y=""
+7 IF $GET(X)
SET Y=$PIECE($GET(^AUPNVSIT(X,0)),U)
+8 QUIT Y
