- BLRSLTL1 ; IHS/DIR/MJL - SET IHS LAB TRANSACTION LOG ; [ 08/01/2002 7:59 AM ]
- ;;5.2T9;LR;**1018**;Nov 17, 2004
- ;;5.2;BLR;**1001,1009**;Mar 7, 2001
- SET ;
- I BLROPT1="ADDCOL" D MODSET Q
- I BLRPHASE="A",BLROPT1="ADDACC" S BLRTEST=+LRTS,BLRACCN=^LRO(68,LRAA,1,LRAD,1,LRAN,.2)
- S BLRVAL=^LRO(69,BLRODT,1,BLRSEQ,0),BLRLRDFN=$P(BLRVAL,U,1),BLRODTM=$P(BLRVAL,U,5),BLRDTC=$P($G(^LRO(69,BLRODT,1,BLRSEQ,1)),U)
- S BLRLRDFN=$P(BLRVAL,U,1),BLRODTM=$P(BLRVAL,U,5),BLRDTC=$P($G(^LRO(69,BLRODT,1,BLRSEQ,1)),U)
- S BLRLOCN=$P(BLRVAL,U,7) S:BLRDTC="" BLRDTC=$P(BLRVAL,U,8)
- S BLRDUZ=$P(BLRVAL,U,2),BLRDUZ2=DUZ(2)
- I BLRDUZ="" S BLRDUZ=.5
- S BLRDUZN=$S($D(^VA(200,BLRDUZ,0)):$P(^(0),U,1),1:"UNK"_BLRDUZ)
- S BLRDFN=$P(^LR(BLRLRDFN,0),U,3),BLRFILE=$P(^LR(BLRLRDFN,0),U,2),BLRODTM=$G(BLRODTM)
- S BLRLOC="" I BLRLOCN'="" S BLRLOC=$O(^SC("B",BLRLOCN,"")) S:BLRLOC="" BLRLOC=$O(^SC("C",BLRLOCN,"")) I BLRLOC="" S X=BLRLOCN,DIC=44,DIC(0)="MX" D ^DIC S BLRLOC=+Y I Y=-1 S BLRLOC=""
- ;S BLRCAT="A" I $L($G(^DPT(BLRDFN,.1))) S BLRCAT="I"
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- S BLRCAT="A" S X=$$GET1^DIQ(2,BLRLRDFN,.103) I X]"",X'["OBSERVATION" S BLRCAT="I"
- ;----- END IHS MODIFICATIONS
- S BLRCLNC="",BLRPCC1=0
- I BLRLOC'="" S BLRCLNC=^SC(BLRLOC,0),BLRIST=$P(BLRCLNC,U,4),BLRCLNC=$P(BLRCLNC,U,7) S:BLRIST="" BLRIST=$G(DUZ(2)) I BLRPCC S BLRPCCC=$P($G(^APCCCTRL(BLRIST,11,BLRLPKG,0)),U,3) I BLRPCCC'="" S BLRPCC1=$S(BLRPCCC:1,1:BLRCAT'="I")
- S BLRPROVN="",BLRPROV=$P(BLRVAL,U,6) S:+BLRPROV>0 BLRPROVN=$P(^VA(200,$P(BLRVAL,U,6),0),U,1) S:BLRPROVN="" BLRPROVN="Unknown Provider"
- S BLRSTR="SEQUENCE NUMBER_$$GETIEN(BLRODTM,BLRSEQ,BLRTEST1)~STATUS FLAG_BLRPHASE~"
- I BLRCMF="C" D
- .S BLRSTR=BLRSTR_"LRFILE_BLRFILE~LRDFN_BLRLRDFN~PATIENT POINTER VALUE_BLRDFN~ORDERING PROVIDER POINTER_BLRPROV~VERIFIER POINTER_BLRDUZ~"
- .S BLRSTR=BLRSTR_"ORDER DATE_$P(BLRVAL,U,5)~ORDER SEQUENCE NUMBER_BLRSEQ~ORDERING PROVIDER NAME_BLRPROVN~ORDER NUMBER_^LRO(69,BLRODT,1,BLRSEQ,.1)~"
- .S BLRSTR=BLRSTR_"COLLECTION DATE/TIME_BLRDTC~VERIFIER NAME_BLRDUZN~ORDERING LOCATION NAME_BLRLOCN~ENTRY DATE/TIME_BLR(""ORDER DATE"")~CLINIC STOP CODE POINTER_BLRCLNC~ORDERING LOCATION POINTER_BLRLOC~DUZ(2)_BLRDUZ2~I/O CATEGORY_BLRCAT~"
- I BLRPHASE="A",BLROPT1="ADDACC" D SET1 Q
- I BLRPHASE="R" S:$G(LRACC)'="" BLRACCN=LRACC S BLRPHASE="A" D SET1 Q
- S BLRTST=0 F S BLRTST=$O(^LRO(69,BLRODT,1,BLRSEQ,2,BLRTST)) Q:'BLRTST D
- .S BLRX=^LRO(69,BLRODT,1,BLRSEQ,2,BLRTST,0),BLRTEST=+BLRX I BLRPHASE="O",BLROPT1="ADDORD",'$D(BLRTSTS(BLRTEST)) Q
- .;I BLRPHASE="A" S BLRACCN="" S:$D(LRACC)'=0 BLRACCN=LRACC
- .I BLRPHASE="A" D ;IHS/DIR TUC/AAB 04/17/98
- ..I BLROPT1="RECCOL"!(BLROPT1="ITMCOL") S BLRACCN=^LRO(68,LRAA,1,LRAD,1,LRAN,.2),BLRSPEC=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0),U) Q
- ..S BLRACCN="" S:$D(LRACC)'=0 BLRACCN=LRACC
- .I $G(LRSS)'="MI",BLRPHASE'="A" D SET1 Q
- .I LRAA=$P(BLRX,U,4),LRAN=$P(BLRX,U,5) D SET1
- Q
- ;
- MODSET ; ;IHS/DIR TUC/AAB 04/01/98
- S BLROAOT=$P(^LRO(69,BLRODT,1,LRPSN,0),U,5)
- S BLRCTST=0 F S BLRCTST=$O(^BLRTXLOG("AOT",BLRODTM,BLRSEQ,BLRCTST)) Q:'BLRCTST D
- .I $D(^BLRTXLOG("AOT",BLROAOT,LRPSN,BLRCTST)) S BLRPHASE="D"
- .S BLRSTR="SEQUENCE NUMBER_$$GETIEN(BLRODTM,BLRSEQ,BLRCTST)~STATUS FLAG_BLRPHASE~" ;FROM AOT
- .S BLRSTR=BLRSTR_"ORDER DATE_$P(^LRO(69,BLRODT,1,LRPSN,0),U,5)~ORDER SEQUENCE NUMBER_LRPSN~ORDER NUMBER_^LRO(69,BLRODT,1,LRPSN,.1)" ;TO AOT
- .D ^BLRFLTL(BLRCMF,BLRSTR)
- .S BLRPHASE="O"
- K BLRCTST,BLROAOT
- Q
- SET1 ;
- S:BLRPHASE'="O" BLRSTR=BLRSTR_"ACCESSION NUMBER_BLRACCN~"
- S BLRLEV=1,BLRCPTL=10000,BLRTEST1=BLRTEST,BLRLEV(1)=BLRTEST,BLRLEV(1,1)="",BLRPAR="",BLRATOM=0 D SET3
- F D SET2 Q:'BLRLEV
- K BLRLEV,BLRPAR
- Q
- ;
- SET2 ;
- S BLRATOM=$O(^LAB(60,BLRLEV(BLRLEV),2,0))="" I BLRATOM,BLRLEV=1 S BLRLEV=0 Q
- S:'BLRATOM BLRLEV=BLRLEV+1 S BLRLEV(BLRLEV,0)=$O(^LAB(60,BLRLEV(BLRLEV-1),2,$G(BLRLEV(BLRLEV,0),0)))
- I BLRLEV(BLRLEV,0) S BLRTEST1=+^LAB(60,BLRLEV(BLRLEV-1),2,$G(BLRLEV(BLRLEV,0),0),0),BLRLEV(BLRLEV)=BLRTEST1 D SET3 Q
- S BLRLEV(BLRLEV,0)=0,BLRLEV=BLRLEV-2
- Q
- ;
- SET3 ;
- S BLRATOM=$O(^LAB(60,BLRTEST1,2,0))="",BLRL60=^LAB(60,BLRTEST1,0),BLRCST=$P(BLRL60,U,11),BLRMOD=$P(BLRL60,U,4)
- S BLRCPTS="" I BLRLEV=1 D CPTCODE
- S BLRSTR1="",BLRSPEC=$G(LRSPEC)
- I BLROPT1="RECCOL"!(BLROPT1="ITMCOL") S BLRSPEC=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0),U) ;IHS/DIR TUC/AAB 04/05/98
- I BLRSPEC'="" D SET4
- S BLRSTR1=BLRSTR1_"CPT LAB CODE POINTER_BLRCPTP~BILLING CPT STRING_BLRCPTS~PANEL/TEST POINTER_BLRTEST1~LAB TEST LIST COST_BLRCST~LAB MODULE_BLRMOD"
- S:BLRDTC'="" BLRSTR1=BLRSTR1_"~COLLECTION DATE/TIME_BLRDTC"
- I BLRCMF="C" S:BLRLEV(BLRLEV,1)'="" BLRPAR=BLRLEV(BLRLEV,1),BLRSTR1=BLRSTR1_"~PARENT POINTER_BLRPAR" S:'BLRATOM BLRLPAR=BLRPAR,BLRSTR1=BLRSTR1_"~@BLRPAR_BLR(""SEQUENCE NUMBER"")"
- S BLRPREV=$O(^BLRTXLOG("AOT",BLRODTM,BLRSEQ,BLRTEST1,""),-1) I BLRPREV'="",$P(^BLRTXLOG(BLRPREV,1),"^",2)'="D",BLRCMF="C" Q
- D ^BLRFLTL(BLRCMF,BLRSTR_BLRSTR1)
- I 'BLRATOM,BLRCMF="C" S BLRLEV(BLRLEV+1,1)=BLRPAR
- Q
- ;
- SET4 ;
- I $D(^LAB(60,BLRTEST1,1,BLRSPEC)) S BLRZ=$G(^LAB(60,BLRTEST1,1,BLRSPEC,0)),BLRUNITS=$P($P(BLRZ,U,7)," ",1),BLRSTR1="SITE/SPECIMEN POINTER_BLRSPEC~UNITS_BLRUNITS~" Q
- S BLRSTR1="SITE/SPECIMEN POINTER_BLRSPEC~"
- Q
- ;
- CPTCODE ; Entry point
- S BLRFOUND=0,(BLRXII,BLRCPTS,BLRCPTP)="" F S BLRXII=$O(^BLRCPT("C",BLRTEST1,BLRXII)) Q:(BLRXII="") I '$P(^BLRCPT(BLRXII,1),U,2) D GETCPT Q:BLRFOUND
- Q
- ;
- GETCPT ;
- Q:BLRODTM<$P(^BLRCPT(BLRXII,0),U,3)
- S BLRFOUND=1,BLRCPTP=BLRXII
- S BLRCPTN=0 F BLRNN=1:1 S BLRCPTN=$O(^BLRCPT(BLRXII,11,BLRCPTN)) Q:'BLRCPTN S BLRCPDAT=^BLRCPT(BLRXII,11,BLRCPTN,0),BLRCPCD=$P(BLRCPDAT,U),BLRCPCST=$P(BLRCPDAT,U,2),BLRCPRC=$P(BLRCPDAT,U,3),BLRCPACT=$P(BLRCPDAT,U,4) D
- .S (BLRCPTM,BLRCPTQ)=""
- .S BLRCPMN=0 F BLRNN1=1:1 S BLRCPMN=$O(^BLRCPT(BLRXII,11,BLRCPTN,1,BLRCPMN)) Q:'BLRCPMN S:BLRNN1>1 BLRCPTM=BLRCPTM_"," S BLRCPTM=BLRCPTM_^BLRCPT(BLRXII,11,BLRCPTN,1,BLRCPMN,0)
- .S BLRCPQN=0 F BLRNN1=1:1 S BLRCPQN=$O(^BLRCPT(BLRXII,11,BLRCPTN,2,BLRCPQN)) Q:'BLRCPQN S:BLRNN1>1 BLRCPTQ=BLRCPTQ_"," S BLRCPTQ=BLRCPTQ_^BLRCPT(BLRXII,11,BLRCPTN,2,BLRCPQN,0)
- .S:BLRNN>1 BLRCPTS=BLRCPTS_";" S BLRCPTS=BLRCPTS_BLRCPCD_"|"_BLRCPCST_"|"_BLRCPRC_"|"_BLRCPACT_"|"_BLRCPTM_"|"_BLRCPTQ
- K BLRCPCD,BLRCPCST,BLRCPRC,BLRCPACT,BLRCPTN,BLRCPDAT,BLRCPTM,BLRCPMN,BLRCPTQ,BLRCPQN,BLRNN,BLRNN1
- Q
- BLRSLTL1 ; IHS/DIR/MJL - SET IHS LAB TRANSACTION LOG ; [ 08/01/2002 7:59 AM ]
- +1 ;;5.2T9;LR;**1018**;Nov 17, 2004
- +2 ;;5.2;BLR;**1001,1009**;Mar 7, 2001
- SET ;
- +1 IF BLROPT1="ADDCOL"
- DO MODSET
- QUIT
- +2 IF BLRPHASE="A"
- IF BLROPT1="ADDACC"
- SET BLRTEST=+LRTS
- SET BLRACCN=^LRO(68,LRAA,1,LRAD,1,LRAN,.2)
- +3 SET BLRVAL=^LRO(69,BLRODT,1,BLRSEQ,0)
- SET BLRLRDFN=$PIECE(BLRVAL,U,1)
- SET BLRODTM=$PIECE(BLRVAL,U,5)
- SET BLRDTC=$PIECE($GET(^LRO(69,BLRODT,1,BLRSEQ,1)),U)
- +4 SET BLRLRDFN=$PIECE(BLRVAL,U,1)
- SET BLRODTM=$PIECE(BLRVAL,U,5)
- SET BLRDTC=$PIECE($GET(^LRO(69,BLRODT,1,BLRSEQ,1)),U)
- +5 SET BLRLOCN=$PIECE(BLRVAL,U,7)
- IF BLRDTC=""
- SET BLRDTC=$PIECE(BLRVAL,U,8)
- +6 SET BLRDUZ=$PIECE(BLRVAL,U,2)
- SET BLRDUZ2=DUZ(2)
- +7 IF BLRDUZ=""
- SET BLRDUZ=.5
- +8 SET BLRDUZN=$SELECT($DATA(^VA(200,BLRDUZ,0)):$PIECE(^(0),U,1),1:"UNK"_BLRDUZ)
- +9 SET BLRDFN=$PIECE(^LR(BLRLRDFN,0),U,3)
- SET BLRFILE=$PIECE(^LR(BLRLRDFN,0),U,2)
- SET BLRODTM=$GET(BLRODTM)
- +10 SET BLRLOC=""
- IF BLRLOCN'=""
- SET BLRLOC=$ORDER(^SC("B",BLRLOCN,""))
- IF BLRLOC=""
- SET BLRLOC=$ORDER(^SC("C",BLRLOCN,""))
- IF BLRLOC=""
- SET X=BLRLOCN
- SET DIC=44
- SET DIC(0)="MX"
- DO ^DIC
- SET BLRLOC=+Y
- IF Y=-1
- SET BLRLOC=""
- +11 ;S BLRCAT="A" I $L($G(^DPT(BLRDFN,.1))) S BLRCAT="I"
- +12 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- +13 SET BLRCAT="A"
- SET X=$$GET1^DIQ(2,BLRLRDFN,.103)
- IF X]""
- IF X'["OBSERVATION"
- SET BLRCAT="I"
- +14 ;----- END IHS MODIFICATIONS
- +15 SET BLRCLNC=""
- SET BLRPCC1=0
- +16 IF BLRLOC'=""
- SET BLRCLNC=^SC(BLRLOC,0)
- SET BLRIST=$PIECE(BLRCLNC,U,4)
- SET BLRCLNC=$PIECE(BLRCLNC,U,7)
- IF BLRIST=""
- SET BLRIST=$GET(DUZ(2))
- IF BLRPCC
- SET BLRPCCC=$PIECE($GET(^APCCCTRL(BLRIST,11,BLRLPKG,0)),U,3)
- IF BLRPCCC'=""
- SET BLRPCC1=$SELECT(BLRPCCC:1,1:BLRCAT'="I")
- +17 SET BLRPROVN=""
- SET BLRPROV=$PIECE(BLRVAL,U,6)
- IF +BLRPROV>0
- SET BLRPROVN=$PIECE(^VA(200,$PIECE(BLRVAL,U,6),0),U,1)
- IF BLRPROVN=""
- SET BLRPROVN="Unknown Provider"
- +18 SET BLRSTR="SEQUENCE NUMBER_$$GETIEN(BLRODTM,BLRSEQ,BLRTEST1)~STATUS FLAG_BLRPHASE~"
- +19 IF BLRCMF="C"
- Begin DoDot:1
- +20 SET BLRSTR=BLRSTR_"LRFILE_BLRFILE~LRDFN_BLRLRDFN~PATIENT POINTER VALUE_BLRDFN~ORDERING PROVIDER POINTER_BLRPROV~VERIFIER POINTER_BLRDUZ~"
- +21 SET BLRSTR=BLRSTR_"ORDER DATE_$P(BLRVAL,U,5)~ORDER SEQUENCE NUMBER_BLRSEQ~ORDERING PROVIDER NAME_BLRPROVN~ORDER NUMBER_^LRO(69,BLRODT,1,BLRSEQ,.1)~"
- +22 SET BLRSTR=BLRSTR_"COLLECTION DATE/TIME_BLRDTC~VERIFIER NAME_BLRDUZN~ORDERING LOCATION NAME_BLRLOCN~ENTRY DATE/TIME_BLR(""ORDER DATE"")~CLINIC STOP CODE POINTER_BLRCLNC~ORDERING LOCATION POINTER_BLRLOC~DUZ(2)_BLRDUZ2~I/O CATEGORY_BLRCAT
- ~"
- End DoDot:1
- +23 IF BLRPHASE="A"
- IF BLROPT1="ADDACC"
- DO SET1
- QUIT
- +24 IF BLRPHASE="R"
- IF $GET(LRACC)'=""
- SET BLRACCN=LRACC
- SET BLRPHASE="A"
- DO SET1
- QUIT
- +25 SET BLRTST=0
- FOR
- SET BLRTST=$ORDER(^LRO(69,BLRODT,1,BLRSEQ,2,BLRTST))
- IF 'BLRTST
- QUIT
- Begin DoDot:1
- +26 SET BLRX=^LRO(69,BLRODT,1,BLRSEQ,2,BLRTST,0)
- SET BLRTEST=+BLRX
- IF BLRPHASE="O"
- IF BLROPT1="ADDORD"
- IF '$DATA(BLRTSTS(BLRTEST))
- QUIT
- +27 ;I BLRPHASE="A" S BLRACCN="" S:$D(LRACC)'=0 BLRACCN=LRACC
- +28 ;IHS/DIR TUC/AAB 04/17/98
- IF BLRPHASE="A"
- Begin DoDot:2
- +29 IF BLROPT1="RECCOL"!(BLROPT1="ITMCOL")
- SET BLRACCN=^LRO(68,LRAA,1,LRAD,1,LRAN,.2)
- SET BLRSPEC=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0),U)
- QUIT
- +30 SET BLRACCN=""
- IF $DATA(LRACC)'=0
- SET BLRACCN=LRACC
- End DoDot:2
- +31 IF $GET(LRSS)'="MI"
- IF BLRPHASE'="A"
- DO SET1
- QUIT
- +32 IF LRAA=$PIECE(BLRX,U,4)
- IF LRAN=$PIECE(BLRX,U,5)
- DO SET1
- End DoDot:1
- +33 QUIT
- +34 ;
- MODSET ; ;IHS/DIR TUC/AAB 04/01/98
- +1 SET BLROAOT=$PIECE(^LRO(69,BLRODT,1,LRPSN,0),U,5)
- +2 SET BLRCTST=0
- FOR
- SET BLRCTST=$ORDER(^BLRTXLOG("AOT",BLRODTM,BLRSEQ,BLRCTST))
- IF 'BLRCTST
- QUIT
- Begin DoDot:1
- +3 IF $DATA(^BLRTXLOG("AOT",BLROAOT,LRPSN,BLRCTST))
- SET BLRPHASE="D"
- +4 ;FROM AOT
- SET BLRSTR="SEQUENCE NUMBER_$$GETIEN(BLRODTM,BLRSEQ,BLRCTST)~STATUS FLAG_BLRPHASE~"
- +5 ;TO AOT
- SET BLRSTR=BLRSTR_"ORDER DATE_$P(^LRO(69,BLRODT,1,LRPSN,0),U,5)~ORDER SEQUENCE NUMBER_LRPSN~ORDER NUMBER_^LRO(69,BLRODT,1,LRPSN,.1)"
- +6 DO ^BLRFLTL(BLRCMF,BLRSTR)
- +7 SET BLRPHASE="O"
- End DoDot:1
- +8 KILL BLRCTST,BLROAOT
- +9 QUIT
- SET1 ;
- +1 IF BLRPHASE'="O"
- SET BLRSTR=BLRSTR_"ACCESSION NUMBER_BLRACCN~"
- +2 SET BLRLEV=1
- SET BLRCPTL=10000
- SET BLRTEST1=BLRTEST
- SET BLRLEV(1)=BLRTEST
- SET BLRLEV(1,1)=""
- SET BLRPAR=""
- SET BLRATOM=0
- DO SET3
- +3 FOR
- DO SET2
- IF 'BLRLEV
- QUIT
- +4 KILL BLRLEV,BLRPAR
- +5 QUIT
- +6 ;
- SET2 ;
- +1 SET BLRATOM=$ORDER(^LAB(60,BLRLEV(BLRLEV),2,0))=""
- IF BLRATOM
- IF BLRLEV=1
- SET BLRLEV=0
- QUIT
- +2 IF 'BLRATOM
- SET BLRLEV=BLRLEV+1
- SET BLRLEV(BLRLEV,0)=$ORDER(^LAB(60,BLRLEV(BLRLEV-1),2,$GET(BLRLEV(BLRLEV,0),0)))
- +3 IF BLRLEV(BLRLEV,0)
- SET BLRTEST1=+^LAB(60,BLRLEV(BLRLEV-1),2,$GET(BLRLEV(BLRLEV,0),0),0)
- SET BLRLEV(BLRLEV)=BLRTEST1
- DO SET3
- QUIT
- +4 SET BLRLEV(BLRLEV,0)=0
- SET BLRLEV=BLRLEV-2
- +5 QUIT
- +6 ;
- SET3 ;
- +1 SET BLRATOM=$ORDER(^LAB(60,BLRTEST1,2,0))=""
- SET BLRL60=^LAB(60,BLRTEST1,0)
- SET BLRCST=$PIECE(BLRL60,U,11)
- SET BLRMOD=$PIECE(BLRL60,U,4)
- +2 SET BLRCPTS=""
- IF BLRLEV=1
- DO CPTCODE
- +3 SET BLRSTR1=""
- SET BLRSPEC=$GET(LRSPEC)
- +4 ;IHS/DIR TUC/AAB 04/05/98
- IF BLROPT1="RECCOL"!(BLROPT1="ITMCOL")
- SET BLRSPEC=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0),U)
- +5 IF BLRSPEC'=""
- DO SET4
- +6 SET BLRSTR1=BLRSTR1_"CPT LAB CODE POINTER_BLRCPTP~BILLING CPT STRING_BLRCPTS~PANEL/TEST POINTER_BLRTEST1~LAB TEST LIST COST_BLRCST~LAB MODULE_BLRMOD"
- +7 IF BLRDTC'=""
- SET BLRSTR1=BLRSTR1_"~COLLECTION DATE/TIME_BLRDTC"
- +8 IF BLRCMF="C"
- IF BLRLEV(BLRLEV,1)'=""
- SET BLRPAR=BLRLEV(BLRLEV,1)
- SET BLRSTR1=BLRSTR1_"~PARENT POINTER_BLRPAR"
- IF 'BLRATOM
- SET BLRLPAR=BLRPAR
- SET BLRSTR1=BLRSTR1_"~@BLRPAR_BLR(""SEQUENCE NUMBER"")"
- +9 SET BLRPREV=$ORDER(^BLRTXLOG("AOT",BLRODTM,BLRSEQ,BLRTEST1,""),-1)
- IF BLRPREV'=""
- IF $PIECE(^BLRTXLOG(BLRPREV,1),"^",2)'="D"
- IF BLRCMF="C"
- QUIT
- +10 DO ^BLRFLTL(BLRCMF,BLRSTR_BLRSTR1)
- +11 IF 'BLRATOM
- IF BLRCMF="C"
- SET BLRLEV(BLRLEV+1,1)=BLRPAR
- +12 QUIT
- +13 ;
- SET4 ;
- +1 IF $DATA(^LAB(60,BLRTEST1,1,BLRSPEC))
- SET BLRZ=$GET(^LAB(60,BLRTEST1,1,BLRSPEC,0))
- SET BLRUNITS=$PIECE($PIECE(BLRZ,U,7)," ",1)
- SET BLRSTR1="SITE/SPECIMEN POINTER_BLRSPEC~UNITS_BLRUNITS~"
- QUIT
- +2 SET BLRSTR1="SITE/SPECIMEN POINTER_BLRSPEC~"
- +3 QUIT
- +4 ;
- CPTCODE ; Entry point
- +1 SET BLRFOUND=0
- SET (BLRXII,BLRCPTS,BLRCPTP)=""
- FOR
- SET BLRXII=$ORDER(^BLRCPT("C",BLRTEST1,BLRXII))
- IF (BLRXII="")
- QUIT
- IF '$PIECE(^BLRCPT(BLRXII,1),U,2)
- DO GETCPT
- IF BLRFOUND
- QUIT
- +2 QUIT
- +3 ;
- GETCPT ;
- +1 IF BLRODTM<$PIECE(^BLRCPT(BLRXII,0),U,3)
- QUIT
- +2 SET BLRFOUND=1
- SET BLRCPTP=BLRXII
- +3 SET BLRCPTN=0
- FOR BLRNN=1:1
- SET BLRCPTN=$ORDER(^BLRCPT(BLRXII,11,BLRCPTN))
- IF 'BLRCPTN
- QUIT
- SET BLRCPDAT=^BLRCPT(BLRXII,11,BLRCPTN,0)
- SET BLRCPCD=$PIECE(BLRCPDAT,U)
- SET BLRCPCST=$PIECE(BLRCPDAT,U,2)
- SET BLRCPRC=$PIECE(BLRCPDAT,U,3)
- SET BLRCPACT=$PIECE(BLRCPDAT,U,4)
- Begin DoDot:1
- +4 SET (BLRCPTM,BLRCPTQ)=""
- +5 SET BLRCPMN=0
- FOR BLRNN1=1:1
- SET BLRCPMN=$ORDER(^BLRCPT(BLRXII,11,BLRCPTN,1,BLRCPMN))
- IF 'BLRCPMN
- QUIT
- IF BLRNN1>1
- SET BLRCPTM=BLRCPTM_","
- SET BLRCPTM=BLRCPTM_^BLRCPT(BLRXII,11,BLRCPTN,1,BLRCPMN,0)
- +6 SET BLRCPQN=0
- FOR BLRNN1=1:1
- SET BLRCPQN=$ORDER(^BLRCPT(BLRXII,11,BLRCPTN,2,BLRCPQN))
- IF 'BLRCPQN
- QUIT
- IF BLRNN1>1
- SET BLRCPTQ=BLRCPTQ_","
- SET BLRCPTQ=BLRCPTQ_^BLRCPT(BLRXII,11,BLRCPTN,2,BLRCPQN,0)
- +7 IF BLRNN>1
- SET BLRCPTS=BLRCPTS_";"
- SET BLRCPTS=BLRCPTS_BLRCPCD_"|"_BLRCPCST_"|"_BLRCPRC_"|"_BLRCPACT_"|"_BLRCPTM_"|"_BLRCPTQ
- End DoDot:1
- +8 KILL BLRCPCD,BLRCPCST,BLRCPRC,BLRCPACT,BLRCPTN,BLRCPDAT,BLRCPTM,BLRCPMN,BLRCPTQ,BLRCPQN,BLRNN,BLRNN1
- +9 QUIT
