- LRSORA3 ;VA/SLC/KCM - SEARCH LAB DATA AND PRINT REPORT ;JUL 06, 2010 3:14 PM;
- ;;5.2;LAB SERVICE;**1,344,1027**;NOV 01, 1997
- BUILD ;
- S LRLOG="I "
- F %=1:1:$L(LRTST(0)) D
- . S LRLOG=LRLOG_$S($E(LRTST(0),%)?1A:"T("_($A(LRTST(0),%)-64)_")",1:$E(LRTST(0),%))
- S LRDFN=0,LRLDFN=0,LREND=0
- D SHORT:'LRLONG,LONG:LRLONG
- Q
- SHORT ;
- S LRVDT=$P(LREDT,".",1)-.01
- F S LRVDT=$O(^LRO(69,LRVDT)) Q:LRVDT=""!(LRVDT>LRSDT) D
- . S LRLLOC=""
- . F S LRLLOC=$O(^LRO(69,LRVDT,1,"AN",LRLLOC)) Q:LRLLOC="" D
- .. S LRDFN=0
- .. F S LRDFN=$O(^LRO(69,LRVDT,1,"AN",LRLLOC,LRDFN)) Q:LRDFN<1 D GIDT
- Q
- GIDT ;
- S LRIDT=0
- F S LRIDT=$O(^LRO(69,LRVDT,1,"AN",LRLLOC,LRDFN,LRIDT)) Q:LRIDT<1 D EVTW
- Q
- LONG ;
- S LRSDT=9999998-LRSDT,LREDT=9999999-LREDT
- S LRDFN=0 F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 D GDATA
- Q
- GDATA ;
- S LRIDT=LRSDT
- F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT=""!(LRIDT>LREDT) D
- . D:$L($P(^LR(LRDFN,"CH",LRIDT,0),U,3)) EVTW
- Q
- EVTW ;
- S %=$G(^LR(LRDFN,"CH",LRIDT,0)) Q:'$L(%)
- I LRAA S LRAAA=$P($P(%,U,6)," ") Q:'$D(LRAA(LRAAA))#2
- K V F J=1:1:LRTST S T(J)=0
- D EVAL Q:$G(LRNOP) X LRLOG
- I $T S LRIDT1=0 F S LRIDT1=$O(V(LRIDT1)) Q:LRIDT1<1 D
- . S LRSUB=0 F S LRSUB=$O(V(LRIDT1,LRSUB)) Q:LRSUB<1 D SET
- Q
- EVAL ;
- F J=1:1:LRTST X LRTST(J,1) D
- . I $T S T(J)=1
- . I S X=$P(LRTST(J,3),U,1)
- . I S $P(V(LRIDT,X),U,1)=$P(^LR(LRDFN,"CH",LRIDT,X),U,1)
- . I S $P(V(LRIDT,X),U,2)=$P(^LR(LRDFN,"CH",LRIDT,X),U,2)
- . I S $P(V(LRIDT,X),U,3)=$P(LRTST(J,2),U,1)
- Q
- SET ;
- K LRWRD
- S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) Q:LRDPF<1!(LRDPF=62.3) D PT^LRX
- I LRPTS Q:'$D(LRPTS(DFN))
- S %=^LR(LRDFN,"CH",LRIDT1,0),LRAN=$P(^(0),U,6),LRLOC=$P(^(0),U,11)
- Q:LRLOC="" I LRLCS Q:'$D(LRLCS(LRLOC))
- ;S LRWRD="" S:LRDPF=2 LRWRD=$S($D(^DPT(DFN,.1)):^(.1),1:"")
- S LRWRD=$G(^DPT(DFN,.1))
- S (Y1,LRDAT)=$P(^LR(LRDFN,"CH",LRIDT1,0),U,1),Y2=1
- S LRCDT=$$DDDATE^LRAFUNC1(Y1,Y2) K Y1,Y2
- ; S LRSUB1=$S(LRSRT="P":PNM_SSN,1:LRLOC)
- S LRSUB1=$S(LRSRT="P":PNM_HRCN,1:LRLOC) ;IHS/ANMC/CLS 08/18/96
- ; S LRSUB2=$S(LRSRT="P":LRDAT,1:PNM_SSN)
- S LRSUB2=$S(LRSRT="P":LRDAT,1:PNM_HRCN) ;IHS/ANMC/CLS 08/18/96
- S LRSUB3=$S(LRSRT="P":LRLOC,1:LRDAT)
- S LRSPEC=$P(^LR(LRDFN,"CH",LRIDT1,0),U,5) D RRNG
- S LRSPEC=$P($G(^LAB(61,LRSPEC,0)),U)
- S LRTEST=LRTSTX
- S LRVAL=$P(V(LRIDT1,LRSUB),U)
- S LRMRK=$P(V(LRIDT1,LRSUB),U,2)
- ; I LRSRT="P" S ^TMP("LR",$J,LRSUB1,LRSPEC,LRTEST,LRIDT)=PNM_U_SSN_U_LRLOC_U_U_LRSPEC_U_U_LRLO_U_LRHI_U_LRVAL_U_LRMRK_U_LRTHER_U_LRWRD_U_LRAN_U_LRDAT_U_LRTEST_U_LRUNITS
- I LRSRT="P" S ^TMP("LR",$J,LRSUB1,LRSPEC,LRTEST,LRIDT)=PNM_U_HRCN_U_LRLOC_U_U_LRSPEC_U_U_LRLO_U_LRHI_U_LRVAL_U_LRMRK_U_LRTHER_U_LRWRD_U_LRAN_U_LRDAT_U_LRTEST_U_LRUNITS ;IHS/ANMC/CLS 08/18/96
- ; I LRSRT'="P" S ^TMP("LR",$J,LRLOC,LRSUB2,LRSPEC,LRTEST,LRIDT)=PNM_U_SSN_U_LRLOC_U_U_LRSPEC_U_U_LRLO_U_LRHI_U_LRVAL_U_LRMRK_U_LRTHER_U_LRWRD_U_LRAN_U_LRDAT_U_LRTEST_U_LRUNITS
- I LRSRT'="P" S ^TMP("LR",$J,LRLOC,LRSUB2,LRSPEC,LRTEST,LRIDT)=PNM_U_HRCN_U_LRLOC_U_U_LRSPEC_U_U_LRLO_U_LRHI_U_LRVAL_U_LRMRK_U_LRTHER_U_LRWRD_U_LRAN_U_LRDAT_U_LRTEST_U_LRUNITS ;IHS/ANMC/CLS 08/18/96
- S C=0
- F S C=$O(^LR(LRDFN,"CH",LRIDT,1,C)) Q:'C D
- . I LRSRT="P" S ^TMP("LR",$J,LRSUB1,LRSPEC,LRTEST,LRIDT,"COM",C)=^LR(LRDFN,"CH",LRIDT,1,C,0)
- . I LRSRT'="P" S ^TMP("LR",$J,LRLOC,LRSUB2,LRSPEC,LRTEST,LRIDT,"COM",C)=^LR(LRDFN,"CH",LRIDT,1,C,0)
- Q
- RRNG ;
- N LRFLAG
- S (LRHI,LRLO,LRTHER,LRFLAG)="",X="CH;"_LRSUB_";1",X=$O(^LAB(60,"C",X,0))
- S LRTSTX=$P(^LAB(60,X,.1),U)
- S LRUNITS=$P($G(^LAB(60,X,1,LRSPEC,0)),"^",7)
- S:$L(X)&$L(LRSPEC) X=$S($D(^LAB(60,X,1,LRSPEC,0)):^(0),1:"") Q:X=""
- ;
- ; check for ranges in file 63
- D CHK63
- ;
- S LRTHER=$P(X,U,11)'=""&($P(X,U,12)'="")
- S LRLO=$S('LRTHER:$P(X,U,2),1:$P(X,U,11))
- S LRHI=$S('LRTHER:$P(X,U,3),1:$P(X,U,12))
- I 'LRFLAG D
- . S @("LRLO="_$S($L(LRLO):LRLO,1:""""""))
- . S @("LRHI="_$S($L(LRHI):LRHI,1:""""""))
- Q
- ;
- CHK63 ;
- N LR63DAT,PC5
- S LR63DAT=$G(^LR(LRDFN,"CH",LRIDT,LRSUB))
- I $G(^LR(LRDFN,"CH",LRIDT,"NPC"))>1,$P(LR63DAT,U,5,12)'="" S LRFLAG=1
- I LRFLAG D
- .S PC5=$P(LR63DAT,U,5)
- .S PC5=$TR(PC5,"!","^")
- .S X=PC5
- Q
- LRSORA3 ;VA/SLC/KCM - SEARCH LAB DATA AND PRINT REPORT ;JUL 06, 2010 3:14 PM;
- +1 ;;5.2;LAB SERVICE;**1,344,1027**;NOV 01, 1997
- BUILD ;
- +1 SET LRLOG="I "
- +2 FOR %=1:1:$LENGTH(LRTST(0))
- Begin DoDot:1
- +3 SET LRLOG=LRLOG_$SELECT($EXTRACT(LRTST(0),%)?1A:"T("_($ASCII(LRTST(0),%)-64)_")",1:$EXTRACT(LRTST(0),%))
- End DoDot:1
- +4 SET LRDFN=0
- SET LRLDFN=0
- SET LREND=0
- +5 IF 'LRLONG
- DO SHORT
- IF LRLONG
- DO LONG
- +6 QUIT
- SHORT ;
- +1 SET LRVDT=$PIECE(LREDT,".",1)-.01
- +2 FOR
- SET LRVDT=$ORDER(^LRO(69,LRVDT))
- IF LRVDT=""!(LRVDT>LRSDT)
- QUIT
- Begin DoDot:1
- +3 SET LRLLOC=""
- +4 FOR
- SET LRLLOC=$ORDER(^LRO(69,LRVDT,1,"AN",LRLLOC))
- IF LRLLOC=""
- QUIT
- Begin DoDot:2
- +5 SET LRDFN=0
- +6 FOR
- SET LRDFN=$ORDER(^LRO(69,LRVDT,1,"AN",LRLLOC,LRDFN))
- IF LRDFN<1
- QUIT
- DO GIDT
- End DoDot:2
- End DoDot:1
- +7 QUIT
- GIDT ;
- +1 SET LRIDT=0
- +2 FOR
- SET LRIDT=$ORDER(^LRO(69,LRVDT,1,"AN",LRLLOC,LRDFN,LRIDT))
- IF LRIDT<1
- QUIT
- DO EVTW
- +3 QUIT
- LONG ;
- +1 SET LRSDT=9999998-LRSDT
- SET LREDT=9999999-LREDT
- +2 SET LRDFN=0
- FOR
- SET LRDFN=$ORDER(^LR(LRDFN))
- IF LRDFN<1
- QUIT
- DO GDATA
- +3 QUIT
- GDATA ;
- +1 SET LRIDT=LRSDT
- +2 FOR
- SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
- IF LRIDT=""!(LRIDT>LREDT)
- QUIT
- Begin DoDot:1
- +3 IF $LENGTH($PIECE(^LR(LRDFN,"CH",LRIDT,0),U,3))
- DO EVTW
- End DoDot:1
- +4 QUIT
- EVTW ;
- +1 SET %=$GET(^LR(LRDFN,"CH",LRIDT,0))
- IF '$LENGTH(%)
- QUIT
- +2 IF LRAA
- SET LRAAA=$PIECE($PIECE(%,U,6)," ")
- IF '$DATA(LRAA(LRAAA))#2
- QUIT
- +3 KILL V
- FOR J=1:1:LRTST
- SET T(J)=0
- +4 DO EVAL
- IF $GET(LRNOP)
- QUIT
- XECUTE LRLOG
- +5 IF $TEST
- SET LRIDT1=0
- FOR
- SET LRIDT1=$ORDER(V(LRIDT1))
- IF LRIDT1<1
- QUIT
- Begin DoDot:1
- +6 SET LRSUB=0
- FOR
- SET LRSUB=$ORDER(V(LRIDT1,LRSUB))
- IF LRSUB<1
- QUIT
- DO SET
- End DoDot:1
- +7 QUIT
- EVAL ;
- +1 FOR J=1:1:LRTST
- XECUTE LRTST(J,1)
- Begin DoDot:1
- +2 IF $TEST
- SET T(J)=1
- +3 IF $TEST
- SET X=$PIECE(LRTST(J,3),U,1)
- +4 IF $TEST
- SET $PIECE(V(LRIDT,X),U,1)=$PIECE(^LR(LRDFN,"CH",LRIDT,X),U,1)
- +5 IF $TEST
- SET $PIECE(V(LRIDT,X),U,2)=$PIECE(^LR(LRDFN,"CH",LRIDT,X),U,2)
- +6 IF $TEST
- SET $PIECE(V(LRIDT,X),U,3)=$PIECE(LRTST(J,2),U,1)
- End DoDot:1
- +7 QUIT
- SET ;
- +1 KILL LRWRD
- +2 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
- SET DFN=$PIECE(^(0),U,3)
- IF LRDPF<1!(LRDPF=62.3)
- QUIT
- DO PT^LRX
- +3 IF LRPTS
- IF '$DATA(LRPTS(DFN))
- QUIT
- +4 SET %=^LR(LRDFN,"CH",LRIDT1,0)
- SET LRAN=$PIECE(^(0),U,6)
- SET LRLOC=$PIECE(^(0),U,11)
- +5 IF LRLOC=""
- QUIT
- IF LRLCS
- IF '$DATA(LRLCS(LRLOC))
- QUIT
- +6 ;S LRWRD="" S:LRDPF=2 LRWRD=$S($D(^DPT(DFN,.1)):^(.1),1:"")
- +7 SET LRWRD=$GET(^DPT(DFN,.1))
- +8 SET (Y1,LRDAT)=$PIECE(^LR(LRDFN,"CH",LRIDT1,0),U,1)
- SET Y2=1
- +9 SET LRCDT=$$DDDATE^LRAFUNC1(Y1,Y2)
- KILL Y1,Y2
- +10 ; S LRSUB1=$S(LRSRT="P":PNM_SSN,1:LRLOC)
- +11 ;IHS/ANMC/CLS 08/18/96
- SET LRSUB1=$SELECT(LRSRT="P":PNM_HRCN,1:LRLOC)
- +12 ; S LRSUB2=$S(LRSRT="P":LRDAT,1:PNM_SSN)
- +13 ;IHS/ANMC/CLS 08/18/96
- SET LRSUB2=$SELECT(LRSRT="P":LRDAT,1:PNM_HRCN)
- +14 SET LRSUB3=$SELECT(LRSRT="P":LRLOC,1:LRDAT)
- +15 SET LRSPEC=$PIECE(^LR(LRDFN,"CH",LRIDT1,0),U,5)
- DO RRNG
- +16 SET LRSPEC=$PIECE($GET(^LAB(61,LRSPEC,0)),U)
- +17 SET LRTEST=LRTSTX
- +18 SET LRVAL=$PIECE(V(LRIDT1,LRSUB),U)
- +19 SET LRMRK=$PIECE(V(LRIDT1,LRSUB),U,2)
- +20 ; I LRSRT="P" S ^TMP("LR",$J,LRSUB1,LRSPEC,LRTEST,LRIDT)=PNM_U_SSN_U_LRLOC_U_U_LRSPEC_U_U_LRLO_U_LRHI_U_LRVAL_U_LRMRK_U_LRTHER_U_LRWRD_U_LRAN_U_LRDAT_U_LRTEST_U_LRUNITS
- +21 ;IHS/ANMC/CLS 08/18/96
- IF LRSRT="P"
- SET ^TMP("LR",$JOB,LRSUB1,LRSPEC,LRTEST,LRIDT)=PNM_U_HRCN_U_LRLOC_U_U_LRSPEC_U_U_LRLO_U_LRHI_U_LRVAL_U_LRMRK_U_LRTHER_U_LRWRD_U_LRAN_U_LRDAT_U_LRTEST_U_LRUNITS
- +22 ; I LRSRT'="P" S ^TMP("LR",$J,LRLOC,LRSUB2,LRSPEC,LRTEST,LRIDT)=PNM_U_SSN_U_LRLOC_U_U_LRSPEC_U_U_LRLO_U_LRHI_U_LRVAL_U_LRMRK_U_LRTHER_U_LRWRD_U_LRAN_U_LRDAT_U_LRTEST_U_LRUNITS
- +23 ;IHS/ANMC/CLS 08/18/96
- IF LRSRT'="P"
- SET ^TMP("LR",$JOB,LRLOC,LRSUB2,LRSPEC,LRTEST,LRIDT)=PNM_U_HRCN_U_LRLOC_U_U_LRSPEC_U_U_LRLO_U_LRHI_U_LRVAL_U_LRMRK_U_LRTHER_U_LRWRD_U_LRAN_U_LRDAT_U_LRTEST_U_LRUNITS
- +24 SET C=0
- +25 FOR
- SET C=$ORDER(^LR(LRDFN,"CH",LRIDT,1,C))
- IF 'C
- QUIT
- Begin DoDot:1
- +26 IF LRSRT="P"
- SET ^TMP("LR",$JOB,LRSUB1,LRSPEC,LRTEST,LRIDT,"COM",C)=^LR(LRDFN,"CH",LRIDT,1,C,0)
- +27 IF LRSRT'="P"
- SET ^TMP("LR",$JOB,LRLOC,LRSUB2,LRSPEC,LRTEST,LRIDT,"COM",C)=^LR(LRDFN,"CH",LRIDT,1,C,0)
- End DoDot:1
- +28 QUIT
- RRNG ;
- +1 NEW LRFLAG
- +2 SET (LRHI,LRLO,LRTHER,LRFLAG)=""
- SET X="CH;"_LRSUB_";1"
- SET X=$ORDER(^LAB(60,"C",X,0))
- +3 SET LRTSTX=$PIECE(^LAB(60,X,.1),U)
- +4 SET LRUNITS=$PIECE($GET(^LAB(60,X,1,LRSPEC,0)),"^",7)
- +5 IF $LENGTH(X)&$LENGTH(LRSPEC)
- SET X=$SELECT($DATA(^LAB(60,X,1,LRSPEC,0)):^(0),1:"")
- IF X=""
- QUIT
- +6 ;
- +7 ; check for ranges in file 63
- +8 DO CHK63
- +9 ;
- +10 SET LRTHER=$PIECE(X,U,11)'=""&($PIECE(X,U,12)'="")
- +11 SET LRLO=$SELECT('LRTHER:$PIECE(X,U,2),1:$PIECE(X,U,11))
- +12 SET LRHI=$SELECT('LRTHER:$PIECE(X,U,3),1:$PIECE(X,U,12))
- +13 IF 'LRFLAG
- Begin DoDot:1
- +14 SET @("LRLO="_$SELECT($LENGTH(LRLO):LRLO,1:""""""))
- +15 SET @("LRHI="_$SELECT($LENGTH(LRHI):LRHI,1:""""""))
- End DoDot:1
- +16 QUIT
- +17 ;
- CHK63 ;
- +1 NEW LR63DAT,PC5
- +2 SET LR63DAT=$GET(^LR(LRDFN,"CH",LRIDT,LRSUB))
- +3 IF $GET(^LR(LRDFN,"CH",LRIDT,"NPC"))>1
- IF $PIECE(LR63DAT,U,5,12)'=""
- SET LRFLAG=1
- +4 IF LRFLAG
- Begin DoDot:1
- +5 SET PC5=$PIECE(LR63DAT,U,5)
- +6 SET PC5=$TRANSLATE(PC5,"!","^")
- +7 SET X=PC5
- End DoDot:1
- +8 QUIT
