LRX ;DALOI/STAFF - UTILITY ROUTINES -- PREVIOUSLY ^LAB("X","...") ;03/31/09 11:39
;;5.2;LAB SERVICE;**65,153,201,217,290,360,350,471**;Sep 27, 1994;Build 1
;
;
PT ; Patient info
;
N X,I,N,Y
D KVAR^VADPT
K LRTREA,LRWRD,AGE
S (AGE,AGE(2),PNM,SEX,DOB,DOD,SSN,VA200,LRWRD,LRRB,LRTREA,VA("PID"),VA("BID"))=""
I $G(LRDFN),'$G(LRDPF),$G(^LR(LRDFN,0)) S LRDPF=$P(^(0),U,2),DFN=$P(^(0),U,3)
S LREND=0
S:$G(DFN)<1!('$G(LRDPF)) LREND=1 Q:$G(LREND)
;
I +$G(LRDPF)'=2 D
. S X=$$GET1^DID(+LRDPF,"","","GLOBAL NAME","ANS","ANS1")
. S X=X_DFN_",0)",X=$S($D(@X):@X,1:""),LRWRD=$S($D(^(.1)):$P(^(.1),U),1:0),LRRB=$S($D(^(.101)):$P(^(.101),U),1:""),DOD=$S($D(^(.35)):$P(^(.35),U),1:"")
. S PNM=$P(X,U),SSN=$P(X,U,9)
. I +$G(LRDPF)=62.3 Q
. S SEX=$P(X,U,2),SEX=$S(SEX="":"M",1:SEX)
. S DOB=$P(X,U,3)
. S AGE=$S($D(DT)&(DOB?1(7N,7N1".".6N)):DT-DOB\10000,1:"??")
. S AGE(2)=$$AGE2(DOB,$G(LRCDT)) ;Age of the patient when the specimen was collected (default =99Yr if no valid DOB present)
. ;Default for LRCDT (collection date) is DT
;
I +$G(LRDPF)=2 D
. N I,X,N,Y
. D OERR^VADPT Q:VAERR
. S PNM=VADM(1)
. S SEX=$P(VADM(5),U),DOB=$P(VADM(3),U),DOD=$P(VADM(6),U)
. S AGE=VADM(4),AGE(2)=$$AGE2(DOB,$G(LRCDT))
. S SSN=VA("PID"),SSN(1)=VA("BID"),LRWRD=$P(VAIN(4),U,2)
. S LRWRD(1)=+VAIN(4),LRRB=VAIN(5),LRPRAC=+VAIN(2)
. S:VAIN(3) LRTREA=+VAIN(3)
;
D SSNFM^LRU
Q
;
;
DEM ; Call DEM^VADPT instead of OERR used above
N X,I,N,Y
D KVAR^VADPT
K LRTREA,LRWRD,AGE
S (AGE,AGE(2),PNM,SEX,DOB,DOD,SSN,VA200,LRWRD,LRRB,LRTREA,VA("PID"),VA("BID"))=""
I $G(LRDFN),'$G(LRDPF),$G(^LR(LRDFN,0)) S LRDPF=$P(^(0),U,2),DFN=$P(^(0),U,3)
S LREND=0 S:$G(DFN)<1!('$G(LRDPF)) LREND=1 Q:$G(LREND)
;
I +$G(LRDPF)'=2 D
. S X=^DIC(+LRDPF,0,"GL")_DFN_",0)",X=$S($D(@X):@X,1:""),LRWRD=$S($D(^(.1)):$P(^(.1),U),1:0),LRRB=$S($D(^(.101)):$P(^(.101),U),1:"")
. S PNM=$P(X,U),SSN=$P(X,U,9)
. I +$G(LRDPF)=62.3 Q
. S SEX=$P(X,U,2),SEX=$S(SEX="":"M",1:SEX),DOB=$P(X,U,3)
. S AGE=$S($D(DT)&(DOB?1(7N,7N1".".6N)):DT-DOB\10000,1:"??")
. S AGE(2)=$$AGE2(DOB,$G(LRCDT))
;
I +$G(LRDPF)=2 N I,X,N,Y D
. D DEM^VADPT Q:VAERR
. S PNM=VADM(1),SEX=$P(VADM(5),U),DOD=$P(VADM(6),U)
. S DOB=$P(VADM(3),U),SSN=VA("PID"),SSN(1)=VA("BID")
. S AGE=VADM(4),AGE(2)=$$AGE2(DOB,$G(LRCDT))
;
D SSNFM^LRU
Q
;
;
DD ;date/time format
S Y=$$FMTE^XLFDT(Y,"5Z")
S Y=$P(Y,"@")_" "_$P($P(Y,"@",2),":",1,2)
Q
;
;
DDOLD ;OLD
I $E(Y,4,7)="0000" S Y=$S($E(Y)=2:"19"_$E(Y,2,3),1:"20"_$E(Y,2,3)) Q
S Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_$S(Y#1:" "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),1:"")
Q
;
;
DT ;current date format is LRDT0
N X,DIK,DIC,%I,DICS,%DT
D DT^DICRW
S Y=$$FMTE^XLFDT(DT,"5D")
S LRDT0=Y
Q
;
;
DTOLD ;2-DIGIT
;current date format is LRDT0
N X,DIK,DIC,%I,DICS,%DT
D DT^DICRW
S Y=$P(DT,".") D DDOLD S LRDTO=Y
Q
;
;
DASH ;line of dashes
W !,$E("--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------",1,IOM-1)
Q
;
;
EQUALS ;line of equals
W !,$E("====================================================================================================================================================================================================================",1,IOM-1)
Q
;
;
DUZ ;user info
S (LRUSNM,LRUSI)="" Q:'$D(X) Q:'$D(^VA(200,+X,0)) S LRUSNM=$P(^(0),"^"),LRUSI=$P(^(0),"^",2)
Q
;
;
DOC ;provider info
I $L(X),'X S LRDOC=X Q
S LRDOC=$P($G(^VA(200,+X,0)),U)
S:LRDOC="" LRDOC="Unknown"
Q
;
;
PRAC(X) ;prac info
N Y
I $L(X),'X Q X
S Y=$P($G(^VA(200,+X,0)),U)
S:Y="" Y="Unknown"
Q Y
;
;
YMD ;year/month/date
S %=%H>21549+%H-.1,%Y=%\365.25+141,%=%#365.25\1,%D=%+306#(%Y#4=0+365)#153#61#31+1,%M=%-%D\29+1,X=%Y_"00"+%M_"00"+%D K %Y,%D,%M,%
Q
;
;
STAMP ;time stamp
S X="N",%DT="ET" D ^%DT
Q
;
;
KEYCOM ;key to result flags
D EQUALS W !!," ------------------------------ COMMENTS ------------------------------",!," Key: 'L' = reference Low, 'H' = reference Hi, '*' = critical range"
Q
;
;
URG ;urgencies
K LRURG S LRURG(0)="ROUTINE" S I=0 F S I=$O(^LAB(62.05,I)) Q:I<1 I $D(^(I,0)) S:'$P(^(0),U,3) LRURG(I)=$P(^(0),U)
Q
;
;
ADD ;date format
S Y=$E("JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC",$E(Y,4,5)*3-2,$E(Y,4,5)*3)_" "_$S(Y#100:$J(Y#100\1,2)_", ",1:"")_(Y\10000+1700)_$S(Y#1:" "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),1:"")
Q
;
;
INF ;Display Infectious Warning
I $L($G(IO)),$D(^LR(LRDFN,.091)),$L(^(.091)),'$G(LRQUIET) W !,$C(7)," Pat Info: ",^(.091) Q
Q
;
;
LRGLIN ;
N HZ
D GSET^%ZISS W IOG1
F HZ=1:1:79 W IOHL
W IOG0 D GKILL^%ZISS
W !
Q
;
;
LRUID(LRAA,LRAD,LRAN) ;Extrinsic function call to create a unique
;accession identifier for an accession number. See description
;of field .092 in file 68 for a full explanation of this number.
;This function returns a value equal to the unique ID generated.
;LRAA=ien in file 68, accession area
;LRAD=ien for accession date in field 68.01
;LRAN=ien for accession number in field 68.02
Q:$S('$G(LRAA):1,'$D(^LRO(68,LRAA,.4)):1,1:0) 0
N DA,DIE,DLAYGO,DR,LRMNTH,LRUID,LRQTR,LRTYPE,LRYR1,LRYR2,LRJUL
S LRUID=$P($G(^LRO(68,LRAA,.4)),"^") ;start building LRUID
S:$L(LRUID)'=2 LRUID="0"_LRUID
S LRTYPE=$P($G(^LRO(68,LRAA,0)),"^",3)
S LRYR1=$E(LRAD,3)
S LRYR2=$E(LRAD,2,3)
S LRMNTH=$E(LRAD,4,5)
S LRQTR=0_(LRMNTH\3.1+1)
I "DW"[LRTYPE D
. S X1=LRAD,X2=$E(LRAD,1,3)_"0101" D ^%DTC
. S X=X+1,LRJUL=$E("000",1,3-$L(X))_X
. S LRUID=LRUID_LRYR1_LRJUL
. S LRUID=LRUID_$E("0000",1,4-$L(LRAN))_LRAN
I LRTYPE="Y" D
. S LRUID=LRUID_LRYR2_$E("000000",1,6-$L(LRAN))_LRAN
I LRTYPE="Q" D
. S LRUID=LRUID_LRYR1_LRQTR
. S LRUID=LRUID_$E("00000",1,5-$L(LRAN))_LRAN
I LRTYPE="M" D
. S LRUID=LRUID_LRYR1_LRMNTH_$E("00000",1,5-$L(LRAN))_LRAN
L +^LRO(68,"C"):99999
I $D(^LRO(68,"C",LRUID)),'$D(^LRO(68,"C",LRUID,LRAA,LRAD,LRAN)) D
. N X
. S X=$E(LRUID,3,10)
. F S LRUID="00"_X Q:'$D(^LRO(68,"C",LRUID)) S X=X+1 S:X>99999999 X=11111111
I $G(LRORDRR)="NSR" Q LRUID ;Special trigger for NSR AP merge
;The following fields are also set in rtn LROLOVER
SET3 I $G(LRORDRR)'="R" S DR="16////"_LRUID
I $G(LRORDRR)="R" D
. S DR=";16.1////"_+$G(LRRSITE("RSITE"))_";16.2////"_+$G(LRRSITE("RPSITE"))_";16.3////"_LRUID_";16.4////"_LRSD("RUID")
. I '$G(LRRSITE("IDTYPE")),'$D(^LRO(68,"C",LRSD("RUID"))) S LRUID=LRSD("RUID") ; Use sender's UID, unless previously used.
. S DR="16////"_LRUID_DR
S DA=LRAN,DA(1)=LRAD,DA(2)=LRAA,DIE="^LRO(68,"_DA(2)_",1,"_DA(1)_",1,",DLAYGO=68
D ^DIE
L -^LRO(68,"C")
S LRORU3=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
Q LRUID
;
KVAR ;Kill laboratory/VADPT patient demographics
K LRTREA,LRWRD,PNM,SEX,DOB,DOD,SSN,LRWRD,LRRB,LRTREA,VA,LRDFN,LRDPF,LREND,VAERR
D KVA^VADPT
Q
ADDPT ;Returns VAPA( Patient data
N X,I,N,Y D ADD^VADPT Q
OPDPT ;Returns VAPD( Patient data
N X,I,N,Y D OPD^VADPT Q
SVCPT ;Returns VASV( Patient data
N X,I,N,Y D SVC^VADPT Q
OADPT ;Returns VAOA( Patient data
N X,I,N,Y D OAD^VADPT Q
INPPT ;Returns VAIN( Patient data
N X,I,N,Y D INP^VADPT Q
IN5PT ;Returns VAIP( Patient data
N X,I,N,Y D IN5^VADPT Q
PIDPT ;Returns VA("PID") and VA("BID") Patient Identifier
N X,I,N,Y D PID^VADPT Q
;
;
QUIT
Y2K(X,LRYR) ; --> used to convert 2digit year to 4digit century and year
; 1/1/91 TO 1/1/1991
;
;S X=$P(X,".") ;--> Date only. Not time
S LRYR=$G(LRYR,"5S")
N YR
S Y=$$FMTE^XLFDT(X,LRYR)
I $L($P(Y,"/"))=1 S $P(Y,"/")="0"_$P(Y,"/") ;--> pad for 2digit day
I $L($P(Y,"/",2))=1 S $P(Y,"/",2)="0"_$P(Y,"/",2) ;--> for 2digit month
Q Y
;
QUIT
RD ;DIR read
N Y,X
K LRANSY,LRANSX
S LREND=0 W !
D ^DIR I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) S LREND=1
S LRANSY=$G(Y),LRANSX=$G(X)
Q
AGE2(DOB,LRCDT) ;Entry point if passing only a valid Date without patient
; DOB, LRCDT must be defined in VA FileManager internal format
; Date error will return 99yr
N X,Y,%DT
I '$G(LRCDT) S LRCDT=$$DT^XLFDT
I '$G(DOB) Q "99yr" ;no DOB passed
S DOB=$P(DOB,".")
S X=DOB,LRCDT=$P(LRCDT,".")
I $S(DOB'=+DOB:1,LRCDT'=+LRCDT:1,1:0) Q "99yr"
I $S(DOB'?7N.NE:1,LRCDT'?7N.NE:1,1:0) Q "99yr"
D ^%DT I Y'>0 Q "99yr" ;invalid date
S X=LRCDT
K %DT D ^%DT I Y'>0 Q "99yr" ;invalid date
;
CALC ;Calculate timeframe based on difference between DOB and collection
; date. Time is stripped off.
; .0001-24 hour = dy
; 0-29 days = dy
; 30-730 dy = mo
; >24 mo = yr
;
I DOB>LRCDT Q "99yr" ;DOB in future
I DOB=LRCDT Q "1dy" ;same dates---pass 1 day old
S X=$E(LRCDT,1,3)-$E(DOB,1,3)-($E(LRCDT,4,7)<$E(DOB,4,7))
I X>1 S X=+X_"yr" Q X ;age 2 years or more---pass in years
S X=$$FMDIFF^XLFDT(LRCDT,DOB,1)
I X>30 S X=X\30_"mo" Q X ;over 30 days---pass in months
E S X=X_"dy" Q X ;under 31 days---pass in days
Q "99yr"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRX 9024 printed Dec 13, 2024@02:23:26 Page 2
LRX ;DALOI/STAFF - UTILITY ROUTINES -- PREVIOUSLY ^LAB("X","...") ;03/31/09 11:39
+1 ;;5.2;LAB SERVICE;**65,153,201,217,290,360,350,471**;Sep 27, 1994;Build 1
+2 ;
+3 ;
PT ; Patient info
+1 ;
+2 NEW X,I,N,Y
+3 DO KVAR^VADPT
+4 KILL LRTREA,LRWRD,AGE
+5 SET (AGE,AGE(2),PNM,SEX,DOB,DOD,SSN,VA200,LRWRD,LRRB,LRTREA,VA("PID"),VA("BID"))=""
+6 IF $GET(LRDFN)
IF '$GET(LRDPF)
IF $GET(^LR(LRDFN,0))
SET LRDPF=$PIECE(^(0),U,2)
SET DFN=$PIECE(^(0),U,3)
+7 SET LREND=0
+8 if $GET(DFN)<1!('$GET(LRDPF))
SET LREND=1
if $GET(LREND)
QUIT
+9 ;
+10 IF +$GET(LRDPF)'=2
Begin DoDot:1
+11 SET X=$$GET1^DID(+LRDPF,"","","GLOBAL NAME","ANS","ANS1")
+12 SET X=X_DFN_",0)"
SET X=$SELECT($DATA(@X):@X,1:"")
SET LRWRD=$SELECT($DATA(^(.1)):$PIECE(^(.1),U),1:0)
SET LRRB=$SELECT($DATA(^(.101)):$PIECE(^(.101),U),1:"")
SET DOD=$SELECT($DATA(^(.35)):$PIECE(^(.35),U),1:"")
+13 SET PNM=$PIECE(X,U)
SET SSN=$PIECE(X,U,9)
+14 IF +$GET(LRDPF)=62.3
QUIT
+15 SET SEX=$PIECE(X,U,2)
SET SEX=$SELECT(SEX="":"M",1:SEX)
+16 SET DOB=$PIECE(X,U,3)
+17 SET AGE=$SELECT($DATA(DT)&(DOB?1(7N,7N1".".6N)):DT-DOB\10000,1:"??")
+18 ;Age of the patient when the specimen was collected (default =99Yr if no valid DOB present)
SET AGE(2)=$$AGE2(DOB,$GET(LRCDT))
+19 ;Default for LRCDT (collection date) is DT
End DoDot:1
+20 ;
+21 IF +$GET(LRDPF)=2
Begin DoDot:1
+22 NEW I,X,N,Y
+23 DO OERR^VADPT
if VAERR
QUIT
+24 SET PNM=VADM(1)
+25 SET SEX=$PIECE(VADM(5),U)
SET DOB=$PIECE(VADM(3),U)
SET DOD=$PIECE(VADM(6),U)
+26 SET AGE=VADM(4)
SET AGE(2)=$$AGE2(DOB,$GET(LRCDT))
+27 SET SSN=VA("PID")
SET SSN(1)=VA("BID")
SET LRWRD=$PIECE(VAIN(4),U,2)
+28 SET LRWRD(1)=+VAIN(4)
SET LRRB=VAIN(5)
SET LRPRAC=+VAIN(2)
+29 if VAIN(3)
SET LRTREA=+VAIN(3)
End DoDot:1
+30 ;
+31 DO SSNFM^LRU
+32 QUIT
+33 ;
+34 ;
DEM ; Call DEM^VADPT instead of OERR used above
+1 NEW X,I,N,Y
+2 DO KVAR^VADPT
+3 KILL LRTREA,LRWRD,AGE
+4 SET (AGE,AGE(2),PNM,SEX,DOB,DOD,SSN,VA200,LRWRD,LRRB,LRTREA,VA("PID"),VA("BID"))=""
+5 IF $GET(LRDFN)
IF '$GET(LRDPF)
IF $GET(^LR(LRDFN,0))
SET LRDPF=$PIECE(^(0),U,2)
SET DFN=$PIECE(^(0),U,3)
+6 SET LREND=0
if $GET(DFN)<1!('$GET(LRDPF))
SET LREND=1
if $GET(LREND)
QUIT
+7 ;
+8 IF +$GET(LRDPF)'=2
Begin DoDot:1
+9 SET X=^DIC(+LRDPF,0,"GL")_DFN_",0)"
SET X=$SELECT($DATA(@X):@X,1:"")
SET LRWRD=$SELECT($DATA(^(.1)):$PIECE(^(.1),U),1:0)
SET LRRB=$SELECT($DATA(^(.101)):$PIECE(^(.101),U),1:"")
+10 SET PNM=$PIECE(X,U)
SET SSN=$PIECE(X,U,9)
+11 IF +$GET(LRDPF)=62.3
QUIT
+12 SET SEX=$PIECE(X,U,2)
SET SEX=$SELECT(SEX="":"M",1:SEX)
SET DOB=$PIECE(X,U,3)
+13 SET AGE=$SELECT($DATA(DT)&(DOB?1(7N,7N1".".6N)):DT-DOB\10000,1:"??")
+14 SET AGE(2)=$$AGE2(DOB,$GET(LRCDT))
End DoDot:1
+15 ;
+16 IF +$GET(LRDPF)=2
NEW I,X,N,Y
Begin DoDot:1
+17 DO DEM^VADPT
if VAERR
QUIT
+18 SET PNM=VADM(1)
SET SEX=$PIECE(VADM(5),U)
SET DOD=$PIECE(VADM(6),U)
+19 SET DOB=$PIECE(VADM(3),U)
SET SSN=VA("PID")
SET SSN(1)=VA("BID")
+20 SET AGE=VADM(4)
SET AGE(2)=$$AGE2(DOB,$GET(LRCDT))
End DoDot:1
+21 ;
+22 DO SSNFM^LRU
+23 QUIT
+24 ;
+25 ;
DD ;date/time format
+1 SET Y=$$FMTE^XLFDT(Y,"5Z")
+2 SET Y=$PIECE(Y,"@")_" "_$PIECE($PIECE(Y,"@",2),":",1,2)
+3 QUIT
+4 ;
+5 ;
DDOLD ;OLD
+1 IF $EXTRACT(Y,4,7)="0000"
SET Y=$SELECT($EXTRACT(Y)=2:"19"_$EXTRACT(Y,2,3),1:"20"_$EXTRACT(Y,2,3))
QUIT
+2 SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)_$SELECT(Y#1:" "_$EXTRACT(Y_0,9,10)_":"_$EXTRACT(Y_"000",11,12),1:"")
+3 QUIT
+4 ;
+5 ;
DT ;current date format is LRDT0
+1 NEW X,DIK,DIC,%I,DICS,%DT
+2 DO DT^DICRW
+3 SET Y=$$FMTE^XLFDT(DT,"5D")
+4 SET LRDT0=Y
+5 QUIT
+6 ;
+7 ;
DTOLD ;2-DIGIT
+1 ;current date format is LRDT0
+2 NEW X,DIK,DIC,%I,DICS,%DT
+3 DO DT^DICRW
+4 SET Y=$PIECE(DT,".")
DO DDOLD
SET LRDTO=Y
+5 QUIT
+6 ;
+7 ;
DASH ;line of dashes
+1 WRITE !,$EXTRACT("--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------",1,IOM-1)
+2 QUIT
+3 ;
+4 ;
EQUALS ;line of equals
+1 WRITE !,$EXTRACT("====================================================================================================================================================================================================================",1,IOM-1)
+2 QUIT
+3 ;
+4 ;
DUZ ;user info
+1 SET (LRUSNM,LRUSI)=""
if '$DATA(X)
QUIT
if '$DATA(^VA(200,+X,0))
QUIT
SET LRUSNM=$PIECE(^(0),"^")
SET LRUSI=$PIECE(^(0),"^",2)
+2 QUIT
+3 ;
+4 ;
DOC ;provider info
+1 IF $LENGTH(X)
IF 'X
SET LRDOC=X
QUIT
+2 SET LRDOC=$PIECE($GET(^VA(200,+X,0)),U)
+3 if LRDOC=""
SET LRDOC="Unknown"
+4 QUIT
+5 ;
+6 ;
PRAC(X) ;prac info
+1 NEW Y
+2 IF $LENGTH(X)
IF 'X
QUIT X
+3 SET Y=$PIECE($GET(^VA(200,+X,0)),U)
+4 if Y=""
SET Y="Unknown"
+5 QUIT Y
+6 ;
+7 ;
YMD ;year/month/date
+1 SET %=%H>21549+%H-.1
SET %Y=%\365.25+141
SET %=%#365.25\1
SET %D=%+306#(%Y#4=0+365)#153#61#31+1
SET %M=%-%D\29+1
SET X=%Y_"00"+%M_"00"+%D
KILL %Y,%D,%M,%
+2 QUIT
+3 ;
+4 ;
STAMP ;time stamp
+1 SET X="N"
SET %DT="ET"
DO ^%DT
+2 QUIT
+3 ;
+4 ;
KEYCOM ;key to result flags
+1 DO EQUALS
WRITE !!," ------------------------------ COMMENTS ------------------------------",!," Key: 'L' = reference Low, 'H' = reference Hi, '*' = critical range"
+2 QUIT
+3 ;
+4 ;
URG ;urgencies
+1 KILL LRURG
SET LRURG(0)="ROUTINE"
SET I=0
FOR
SET I=$ORDER(^LAB(62.05,I))
if I<1
QUIT
IF $DATA(^(I,0))
if '$PIECE(^(0),U,3)
SET LRURG(I)=$PIECE(^(0),U)
+2 QUIT
+3 ;
+4 ;
ADD ;date format
+1 SET Y=$EXTRACT("JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC",$EXTRACT(Y,4,5)*3-2,$EXTRACT(Y,4,5)*3)_" "_$SELECT(Y#100:$JUSTIFY(Y#100\1,2)_", ",1:"")_(Y\10000+1700)_$SELECT(Y#1:" "_$EXTRACT(Y_0,9,10)_":"_$EXTRACT(Y_"000",11,12),1:"")
+2 QUIT
+3 ;
+4 ;
INF ;Display Infectious Warning
+1 IF $LENGTH($GET(IO))
IF $DATA(^LR(LRDFN,.091))
IF $LENGTH(^(.091))
IF '$GET(LRQUIET)
WRITE !,$CHAR(7)," Pat Info: ",^(.091)
QUIT
+2 QUIT
+3 ;
+4 ;
LRGLIN ;
+1 NEW HZ
+2 DO GSET^%ZISS
WRITE IOG1
+3 FOR HZ=1:1:79
WRITE IOHL
+4 WRITE IOG0
DO GKILL^%ZISS
+5 WRITE !
+6 QUIT
+7 ;
+8 ;
LRUID(LRAA,LRAD,LRAN) ;Extrinsic function call to create a unique
+1 ;accession identifier for an accession number. See description
+2 ;of field .092 in file 68 for a full explanation of this number.
+3 ;This function returns a value equal to the unique ID generated.
+4 ;LRAA=ien in file 68, accession area
+5 ;LRAD=ien for accession date in field 68.01
+6 ;LRAN=ien for accession number in field 68.02
+7 if $SELECT('$GET(LRAA)
QUIT 0
+8 NEW DA,DIE,DLAYGO,DR,LRMNTH,LRUID,LRQTR,LRTYPE,LRYR1,LRYR2,LRJUL
+9 ;start building LRUID
SET LRUID=$PIECE($GET(^LRO(68,LRAA,.4)),"^")
+10 if $LENGTH(LRUID)'=2
SET LRUID="0"_LRUID
+11 SET LRTYPE=$PIECE($GET(^LRO(68,LRAA,0)),"^",3)
+12 SET LRYR1=$EXTRACT(LRAD,3)
+13 SET LRYR2=$EXTRACT(LRAD,2,3)
+14 SET LRMNTH=$EXTRACT(LRAD,4,5)
+15 SET LRQTR=0_(LRMNTH\3.1+1)
+16 IF "DW"[LRTYPE
Begin DoDot:1
+17 SET X1=LRAD
SET X2=$EXTRACT(LRAD,1,3)_"0101"
DO ^%DTC
+18 SET X=X+1
SET LRJUL=$EXTRACT("000",1,3-$LENGTH(X))_X
+19 SET LRUID=LRUID_LRYR1_LRJUL
+20 SET LRUID=LRUID_$EXTRACT("0000",1,4-$LENGTH(LRAN))_LRAN
End DoDot:1
+21 IF LRTYPE="Y"
Begin DoDot:1
+22 SET LRUID=LRUID_LRYR2_$EXTRACT("000000",1,6-$LENGTH(LRAN))_LRAN
End DoDot:1
+23 IF LRTYPE="Q"
Begin DoDot:1
+24 SET LRUID=LRUID_LRYR1_LRQTR
+25 SET LRUID=LRUID_$EXTRACT("00000",1,5-$LENGTH(LRAN))_LRAN
End DoDot:1
+26 IF LRTYPE="M"
Begin DoDot:1
+27 SET LRUID=LRUID_LRYR1_LRMNTH_$EXTRACT("00000",1,5-$LENGTH(LRAN))_LRAN
End DoDot:1
+28 LOCK +^LRO(68,"C"):99999
+29 IF $DATA(^LRO(68,"C",LRUID))
IF '$DATA(^LRO(68,"C",LRUID,LRAA,LRAD,LRAN))
Begin DoDot:1
+30 NEW X
+31 SET X=$EXTRACT(LRUID,3,10)
+32 FOR
SET LRUID="00"_X
if '$DATA(^LRO(68,"C",LRUID))
QUIT
SET X=X+1
if X>99999999
SET X=11111111
End DoDot:1
+33 ;Special trigger for NSR AP merge
IF $GET(LRORDRR)="NSR"
QUIT LRUID
+34 ;The following fields are also set in rtn LROLOVER
SET3 IF $GET(LRORDRR)'="R"
SET DR="16////"_LRUID
+1 IF $GET(LRORDRR)="R"
Begin DoDot:1
+2 SET DR=";16.1////"_+$GET(LRRSITE("RSITE"))_";16.2////"_+$GET(LRRSITE("RPSITE"))_";16.3////"_LRUID_";16.4////"_LRSD("RUID")
+3 ; Use sender's UID, unless previously used.
IF '$GET(LRRSITE("IDTYPE"))
IF '$DATA(^LRO(68,"C",LRSD("RUID")))
SET LRUID=LRSD("RUID")
+4 SET DR="16////"_LRUID_DR
End DoDot:1
+5 SET DA=LRAN
SET DA(1)=LRAD
SET DA(2)=LRAA
SET DIE="^LRO(68,"_DA(2)_",1,"_DA(1)_",1,"
SET DLAYGO=68
+6 DO ^DIE
+7 LOCK -^LRO(68,"C")
+8 SET LRORU3=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
+9 QUIT LRUID
+10 ;
KVAR ;Kill laboratory/VADPT patient demographics
+1 KILL LRTREA,LRWRD,PNM,SEX,DOB,DOD,SSN,LRWRD,LRRB,LRTREA,VA,LRDFN,LRDPF,LREND,VAERR
+2 DO KVA^VADPT
+3 QUIT
ADDPT ;Returns VAPA( Patient data
+1 NEW X,I,N,Y
DO ADD^VADPT
QUIT
OPDPT ;Returns VAPD( Patient data
+1 NEW X,I,N,Y
DO OPD^VADPT
QUIT
SVCPT ;Returns VASV( Patient data
+1 NEW X,I,N,Y
DO SVC^VADPT
QUIT
OADPT ;Returns VAOA( Patient data
+1 NEW X,I,N,Y
DO OAD^VADPT
QUIT
INPPT ;Returns VAIN( Patient data
+1 NEW X,I,N,Y
DO INP^VADPT
QUIT
IN5PT ;Returns VAIP( Patient data
+1 NEW X,I,N,Y
DO IN5^VADPT
QUIT
PIDPT ;Returns VA("PID") and VA("BID") Patient Identifier
+1 NEW X,I,N,Y
DO PID^VADPT
QUIT
+2 ;
+3 ;
+4 QUIT
Y2K(X,LRYR) ; --> used to convert 2digit year to 4digit century and year
+1 ; 1/1/91 TO 1/1/1991
+2 ;
+3 ;S X=$P(X,".") ;--> Date only. Not time
+4 SET LRYR=$GET(LRYR,"5S")
+5 NEW YR
+6 SET Y=$$FMTE^XLFDT(X,LRYR)
+7 ;--> pad for 2digit day
IF $LENGTH($PIECE(Y,"/"))=1
SET $PIECE(Y,"/")="0"_$PIECE(Y,"/")
+8 ;--> for 2digit month
IF $LENGTH($PIECE(Y,"/",2))=1
SET $PIECE(Y,"/",2)="0"_$PIECE(Y,"/",2)
+9 QUIT Y
+10 ;
+11 QUIT
RD ;DIR read
+1 NEW Y,X
+2 KILL LRANSY,LRANSX
+3 SET LREND=0
WRITE !
+4 DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
SET LREND=1
+5 SET LRANSY=$GET(Y)
SET LRANSX=$GET(X)
+6 QUIT
AGE2(DOB,LRCDT) ;Entry point if passing only a valid Date without patient
+1 ; DOB, LRCDT must be defined in VA FileManager internal format
+2 ; Date error will return 99yr
+3 NEW X,Y,%DT
+4 IF '$GET(LRCDT)
SET LRCDT=$$DT^XLFDT
+5 ;no DOB passed
IF '$GET(DOB)
QUIT "99yr"
+6 SET DOB=$PIECE(DOB,".")
+7 SET X=DOB
SET LRCDT=$PIECE(LRCDT,".")
+8 IF $SELECT(DOB'=+DOB:1,LRCDT'=+LRCDT:1,1:0)
QUIT "99yr"
+9 IF $SELECT(DOB'?7N.NE:1,LRCDT'?7N.NE:1,1:0)
QUIT "99yr"
+10 ;invalid date
DO ^%DT
IF Y'>0
QUIT "99yr"
+11 SET X=LRCDT
+12 ;invalid date
KILL %DT
DO ^%DT
IF Y'>0
QUIT "99yr"
+13 ;
CALC ;Calculate timeframe based on difference between DOB and collection
+1 ; date. Time is stripped off.
+2 ; .0001-24 hour = dy
+3 ; 0-29 days = dy
+4 ; 30-730 dy = mo
+5 ; >24 mo = yr
+6 ;
+7 ;DOB in future
IF DOB>LRCDT
QUIT "99yr"
+8 ;same dates---pass 1 day old
IF DOB=LRCDT
QUIT "1dy"
+9 SET X=$EXTRACT(LRCDT,1,3)-$EXTRACT(DOB,1,3)-($EXTRACT(LRCDT,4,7)<$EXTRACT(DOB,4,7))
+10 ;age 2 years or more---pass in years
IF X>1
SET X=+X_"yr"
QUIT X
+11 SET X=$$FMDIFF^XLFDT(LRCDT,DOB,1)
+12 ;over 30 days---pass in months
IF X>30
SET X=X\30_"mo"
QUIT X
+13 ;under 31 days---pass in days
IF '$TEST
SET X=X_"dy"
QUIT X
+14 QUIT "99yr"
