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
