Routine: LRXSAVE

LRX ;SLC/BA- UTILITY ROUTINES -- PREVIOUSLY ^LAB("X","...") ; 3/28/89  19:43 ; [ 09/08/90  7:16 PM ]

 ;;V~5.0~;LAB;;02/27/90 17:09

PT ;patient info

 S U="^" I $D(LRDPF),LRDPF'<1 S X=^DIC(+LRDPF,0,"GL")_DFN_",0)",X=$S($D(@X):@X,1:""),LRWRD=$S($D(^(.1)):$P(^(.1),U),1:"")

 I '$D(LRDPF) S X=$S($D(^DPT(DFN,0))#2:^(0),$D(^LAB(62.3,DFN,0)):^(0),1:""),LRDPF=2

 S PNM=$P(X,U),SEX=$P(X,U,2),SEX=$S(SEX="":"M",1:SEX),DOB=$P(X,U,3),AGE=$S($D(DT)&(DOB?7N):DT-DOB\10000,1:"??"),X=$P(X,U,9),SSN=$S(+LRDPF=2:$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,9),1:X)

 S HRCN=$S($D(^AUPNPAT(DFN,41,DUZ(2),0)):$P(^(0),U,2),1:"?")  ;IHS/ANMC/CLS 11/02/89

 I AGE<2 S XN=X,DIC=9000001,DR=1102.98,DA=DFN D ^AUDICLK S AGE=$S($D(LKPRINT):LKPRINT,1:"??"),X=XN K DA,DIC,DR,G,LKPRINT,XN,Y  ;IHS/ANMC/CLS 05/01/90 PRINTABLE AGE

DD ;date/time format

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

DT ;current date format is LRDT0

 S %H=+$H D YMD^%DTC S DT=X

 S Y=$P(DT,".",1) D DD S LRDT0=Y

DASH ;line of dashes

 W !,$E("--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------",1,IOM-1)

EQUALS ;line of equals

 W !,$E("====================================================================================================================================================================================================================",1,IOM-1)

DUZ ;user info

 S (LRUSNM,LRUSI)="" Q:'$D(X)  Q:'$D(^DIC(3,+X,0))  S LRUSNM=$P(^(0),"^",1),LRUSI=$P(^(0),"^",2)

DOC ;provider info

 S LRDOC=$S($D(^DIC(16,+X,0)):$P(^(0),U),1:"") S:LRDOC="" LRDOC=$S($D(^DIC(6,+X,0)):$P(^(0),U),1:"Unknown")

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,%

STAMP ;time stamp

 S X="N",%DT="ET" D ^%DT

KEYCOM ;key to result flags

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

URG ;urgencys

 K LRURG S LRURG(0)="ROUTINE" F I=0:0 S I=$N(^LAB(62.05,I)) Q:I<1  S LRURG(I)=$P(^(I,0),U)

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

INF ;Display Infectious Warning

 I $D(^LR(LRDFN,.091)),$L(^(.091)) W !,*7," Pat Info: ",^(.091) Q

LRX       ;SLC/BA- UTILITY ROUTINES -- PREVIOUSLY ^LAB("X","...") ; 3/28/89  19:43 ; [ 09/08/90  7:16 PM ]

 +1       ;;V~5.0~;LAB;;02/27/90 17:09

PT        ;patient info

 +1        SET U="^"

           IF $DATA(LRDPF)

               IF LRDPF'<1

                   SET X=^DIC(+LRDPF,0,"GL")_DFN_",0)"

                   SET X=$SELECT($DATA(@X):@X,1:"")

                   SET LRWRD=$SELECT($DATA(^(.1)):$PIECE(^(.1),U),1:"")

 +2        IF '$DATA(LRDPF)

               SET X=$SELECT($DATA(^DPT(DFN,0))#2:^(0),$DATA(^LAB(62.3,DFN,0)):^(0),1:"")

               SET LRDPF=2

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

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

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

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

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

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

           SET SSN=$SELECT(+LRDPF=2:$EXTRACT(X,1,3)_"-"_$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,9),1:X)

 +4       ;IHS/ANMC/CLS 11/02/89

           SET HRCN=$SELECT($DATA(^AUPNPAT(DFN,41,DUZ(2),0)):$PIECE(^(0),U,2),1:"?")

 +5       ;IHS/ANMC/CLS 05/01/90 PRINTABLE AGE

           IF AGE<2

               SET XN=X

               SET DIC=9000001

               SET DR=1102.98

               SET DA=DFN

               DO ^AUDICLK

               SET AGE=$SELECT($DATA(LKPRINT):LKPRINT,1:"??")

               SET X=XN

               KILL DA,DIC,DR,G,LKPRINT,XN,Y

 +6        QUIT

DD        ;date/time format

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

 +2        QUIT

DT        ;current date format is LRDT0

 +1        SET %H=+$HOROLOG

           DO YMD^%DTC

           SET DT=X

 +2        SET Y=$PIECE(DT,".",1)

           DO DD

           SET LRDT0=Y

 +3        QUIT

DASH      ;line of dashes

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

 +2        QUIT

EQUALS    ;line of equals

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

 +2        QUIT

DUZ       ;user info

 +1        SET (LRUSNM,LRUSI)=""

           IF '$DATA(X)

               QUIT

           IF '$DATA(^DIC(3,+X,0))

               QUIT

           SET LRUSNM=$PIECE(^(0),"^",1)

           SET LRUSI=$PIECE(^(0),"^",2)

 +2        QUIT

DOC       ;provider info

 +1        SET LRDOC=$SELECT($DATA(^DIC(16,+X,0)):$PIECE(^(0),U),1:"")

           IF LRDOC=""

               SET LRDOC=$SELECT($DATA(^DIC(6,+X,0)):$PIECE(^(0),U),1:"Unknown")

 +2        QUIT

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

STAMP     ;time stamp

 +1        SET X="N"

           SET %DT="ET"

           DO ^%DT

 +2        QUIT

KEYCOM    ;key to result flags

 +1        DO EQUALS

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

 +2        QUIT

URG       ;urgencys

 +1        KILL LRURG

           SET LRURG(0)="ROUTINE"

           FOR I=0:0

LRXSAVE.m