LRX.m

LRX ;SLC/BA/DALISC/FHS - UTILITY ROUTINES -- PREVIOUSLY ^LAB("X","...") ;2/8/91  07:30

 ;;5.2;LAB SERVICE;**1031**;NOV 1, 1997

 ;

 ;;VA LR Patch(s): 65,153,201,217,290,360

 ;

PT ;patient info

 ;

 N X,I,N,Y

 ; D KVAR^VADPT

 ; 

 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031

 D @$S($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT")

 S HRCN=""

 ; ----- END IHS/MSC/MKK - LR*5.2*1031

 ; 

 K LRTREA,LRWRD,AGE S (AGE,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(1,+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) Q:+$G(LRDPF)=62.3

 . 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 D:'VAERR

 . D @$S($$ISPIMS^BLRUTIL:"OERR^VADPT",1:"OERR^BLRDPT") D:'VAERR     ; IHS/MSC/MKK LR*5.2*1031

 . . 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=$P(VADM(2),U),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

 ; 

 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031

 D @$S($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT")

 S HRCN=""

 ; ----- END IHS/MSC/MKK - LR*5.2*1031

 ; 

 K LRTREA,LRWRD,AGE S (AGE,PNM,SEX,DOB,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),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))

 . S SSN=$P(X,U,9)

 I +$G(LRDPF)=2 N I,X,N,Y D

 . ; D DEM^VADPT D:'VAERR

 . D @$S($$ISPIMS^BLRUTIL:"DEM^VADPT",1:"DEM^BLRDPT") D:'VAERR  ; IHS/OIT/MKK - LR*5.2*1030

 . . S PNM=VADM(1),SEX=$P(VADM(5),U)

 . . S DOB=$P(VADM(3),U),SSN=$P(VADM(2),U)

 . . 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 ;urgencys

 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

 ;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

 ; 

 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031

 D @$S($$ISPIMS^BLRUTIL:"KVA^VADPT",1:"KVA^BLRDPT")                  ; IHS/MSC/MKK - LR*5.2*1031

 K HRCN

 ; ----- END IHS/MSC/MKK - LR*5.2*1031

 Q

 ;

ADDPT ;Returns VAPA( Patient data

 ; N X,I,N,Y D ADD^VADPT Q

 N X,I,N,Y D @$S($$ISPIMS^BLRUTIL:"ADD^VADPT",1:"ADD^BLRDPT") Q      ; IHS/MSC/MKK - LR*5.2*1031

 ;

OPDPT ;Returns VAPD( Patient data

 ; N X,I,N,Y D OPD^VADPT Q

 N X,I,N,Y D @$S($$ISPIMS^BLRUTIL:"OPD^VADPT",1:"OPD^BLRDPT") Q      ; IHS/MSC/MKK - LR*5.2*1031

 ;

SVCPT ;Returns VASV( Patient data

 ; N X,I,N,Y D SVC^VADPT Q

 N X,I,N,Y D @$S($$ISPIMS^BLRUTIL:"SVC^VADPT",1:"SVC^BLRDPT") Q      ; IHS/MSC/MKK - LR*5.2*1031

 ;

OADPT ;Returns VAOA( Patient data

 ; N X,I,N,Y D OAD^VADPT Q

 N X,I,N,Y D @$S($$ISPIMS^BLRUTIL:"OAD^VADPT",1:"OAD^BLRDPT") Q      ; IHS/MSC/MKK - LR*5.2*1031

 ;

INPPT ;Returns VAIN( Patient data

 ; N X,I,N,Y D INP^VADPT Q

 N X,I,N,Y D @$S($$ISPIMS^BLRUTIL:"INP^VADPT",1:"INP^BLRDPT") Q      ; IHS/MSC/MKK - LR*5.2*1031

 ;

IN5PT ;Returns VAIP( Patient data

 ; N X,I,N,Y D IN5^VADPT Q

 N X,I,N,Y D @$S($$ISPIMS^BLRUTIL:"IN5^VADPT",1:"IN5^BLRDPT") Q      ; IHS/MSC/MKK - LR*5.2*1031

 ;

PIDPT ;Returns VA("PID") and VA("BID") Patient Identifier

 ; N X,I,N,Y D PID^VADPT Q

 N X,I,N,Y D @$S($$ISPIMS^BLRUTIL:"PID^VADPT",1:"PID^BLRDPT") Q      ; IHS/MSC/MKK - LR*5.2*1031

 ;

 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"

LRX       ;SLC/BA/DALISC/FHS - UTILITY ROUTINES -- PREVIOUSLY ^LAB("X","...") ;2/8/91  07:30

 +1       ;;5.2;LAB SERVICE;**1031**;NOV 1, 1997

 +2       ;

 +3       ;;VA LR Patch(s): 65,153,201,217,290,360

 +4       ;

PT        ;patient info

 +1       ;

 +2        NEW X,I,N,Y

 +3       ; D KVAR^VADPT

 +4       ; 

 +5       ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031

 +6        DO @$SELECT($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT")

 +7        SET HRCN=""

 +8       ; ----- END IHS/MSC/MKK - LR*5.2*1031

 +9       ; 

 +10       KILL LRTREA,LRWRD,AGE

           SET (AGE,PNM,SEX,DOB,DOD,SSN,VA200,LRWRD,LRRB,LRTREA,VA("PID"),VA("BID"))=""

 +11       IF $GET(LRDFN)

               IF '$GET(LRDPF)

                   IF $GET(^LR(LRDFN,0))

                       SET LRDPF=$PIECE(^(0),U,2)

                       SET DFN=$PIECE(^(0),U,3)

 +12       SET LREND=0

           IF $GET(DFN)<1!('$GET(LRDPF))

               SET LREND=1

           IF $GET(LREND)

               QUIT 

 +13       IF +$GET(LRDPF)'=2

               Begin DoDot:1

 +14               SET X=$$GET1^DID(1,+LRDPF,"","GLOBAL NAME","ANS","ANS1")

 +15               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:"")

 +16               SET PNM=$PIECE(X,U)

                   SET SSN=$PIECE(X,U,9)

                   IF +$GET(LRDPF)=62.3

                       QUIT 

 +17               SET SEX=$PIECE(X,U,2)

                   SET SEX=$SELECT(SEX="":"M",1:SEX)

 +18               SET DOB=$PIECE(X,U,3)

 +19               SET AGE=$SELECT($DATA(DT)&(DOB?1(7N,7N1".".6N)):DT-DOB\10000,1:"??")

 +20      ;Age of the patient when the specimen was collected (default =99Yr if no valid DOB present)

                   SET AGE(2)=$$AGE2(DOB,$GET(LRCDT))

 +21      ;Default for LRCDT (collection date) is DT

               End DoDot:1

 +22       IF +$GET(LRDPF)=2

               Begin DoDot:1

 +23               NEW I,X,N,Y

 +24      ; D OERR^VADPT D:'VAERR

 +25      ; IHS/MSC/MKK LR*5.2*1031

                   DO @$SELECT($$ISPIMS^BLRUTIL:"OERR^VADPT",1:"OERR^BLRDPT")

                   IF 'VAERR

                       Begin DoDot:2

 +26                       SET PNM=VADM(1)

 +27                       SET SEX=$PIECE(VADM(5),U)

                           SET DOB=$PIECE(VADM(3),U)

                           SET DOD=$PIECE(VADM(6),U)

 +28                       SET AGE=VADM(4)

                           SET AGE(2)=$$AGE2(DOB,$GET(LRCDT))

 +29                       SET SSN=$PIECE(VADM(2),U)

                           SET LRWRD=$PIECE(VAIN(4),U,2)

 +30                       SET LRWRD(1)=+VAIN(4)

                           SET LRRB=VAIN(5)

                           SET LRPRAC=+VAIN(2)

 +31                       IF VAIN(3)

                               SET LRTREA=+VAIN(3)

                       End DoDot:2

               End DoDot:1

 +32       DO SSNFM^LRU

 +33       QUIT 

 +34      ;

DEM       ;Call DEM^VADPT instead of OERR used above

 +1        NEW X,I,N,Y

 +2       ; D KVAR^VADPT

 +3       ; 

 +4       ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031

 +5        DO @$SELECT($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT")

 +6        SET HRCN=""

 +7       ; ----- END IHS/MSC/MKK - LR*5.2*1031

 +8       ; 

 +9        KILL LRTREA,LRWRD,AGE

           SET (AGE,PNM,SEX,DOB,SSN,VA200,LRWRD,LRRB,LRTREA,VA("PID"),VA("BID"))=""

 +10       IF $GET(LRDFN)

               IF '$GET(LRDPF)

                   IF $GET(^LR(LRDFN,0))

                       SET LRDPF=$PIECE(^(0),U,2)

                       SET DFN=$PIECE(^(0),U,3)

 +11       SET LREND=0

           IF $GET(DFN)<1!('$GET(LRDPF))

               SET LREND=1

           IF $GET(LREND)

               QUIT 

 +12       IF +$GET(LRDPF)'=2

               Begin DoDot:1

 +13               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:"")

 +14               SET PNM=$PIECE(X,U)

                   SET SEX=$PIECE(X,U,2)

                   SET SEX=$SELECT(SEX="":"M",1:SEX)

                   SET DOB=$PIECE(X,U,3)

 +15               SET AGE=$SELECT($DATA(DT)&(DOB?1(7N,7N1".".6N)):DT-DOB\10000,1:"??")

 +16               SET AGE(2)=$$AGE2(DOB,$GET(LRCDT))

 +17               SET SSN=$PIECE(X,U,9)

               End DoDot:1

 +18       IF +$GET(LRDPF)=2

               NEW I,X,N,Y

               Begin DoDot:1

 +19      ; D DEM^VADPT D:'VAERR

 +20      ; IHS/OIT/MKK - LR*5.2*1030

                   DO @$SELECT($$ISPIMS^BLRUTIL:"DEM^VADPT",1:"DEM^BLRDPT")

                   IF 'VAERR

                       Begin DoDot:2

 +21                       SET PNM=VADM(1)

                           SET SEX=$PIECE(VADM(5),U)

 +22                       SET DOB=$PIECE(VADM(3),U)

                           SET SSN=$PIECE(VADM(2),U)

 +23                       SET AGE=VADM(4)

                           SET AGE(2)=$$AGE2(DOB,$GET(LRCDT))

                       End DoDot:2

               End DoDot:1

 +24       DO SSNFM^LRU

 +25       QUIT 

 +26      ;

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       ;

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       ;

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       ;

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       ;

DASH      ;line of dashes

 +1        WRITE !,$EXTRACT("--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------",1,IOM-1)

 +2        QUIT 

 +3       ;

EQUALS    ;line of equals

 +1        WRITE !,$EXTRACT("====================================================================================================================================================================================================================",1,IOM-1)

 +2        QUIT 

 +3       ;

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       ;

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       ;

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       ;

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       ;

STAMP     ;time stamp

 +1        SET X="N"

           SET %DT="ET"

           DO ^%DT

 +2        QUIT 

 +3       ;

KEYCOM    ;key to result flags

 +1        DO EQUALS

           WRITE !!,"  ------------------------------  COMMENTS  ------------------------------",!,"  Key:  'L' = reference Low,  'H' = reference Hi, '*' = critical range"

 +2        QUIT 

 +3       ;

URG       ;urgencys

 +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       ;

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       ;

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       ;

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       ;

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))