- BLRTNA ;IHS/ITSC/TPF - CREATE/EDIT TRANSACTIONS [ 12/19/2002 6:40 AM ]
- ;;5.2;IHS LABORATORY;**1028**;NOV 01, 1997;Build 46
- ;;5.2;LR;**1013,1015**;NOV 18, 2002
- ;
- CPTCODE ;EP - CALLED FROM BLRTN,BLRTNB,BLRTNM1
- D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER CPTCODE^BLRTNA")
- 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
- D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("EXIT CPTCODE^BLRTNA")
- Q
- ;
- GETCPT ;EP - CALLED FROM BLRTN
- D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER GETCPT^BLRTNA")
- Q:BLRODTM<$P($G(^BLRCPT(BLRXII,0)),U,3)
- S BLRFOUND=1,BLRCPTP=BLRXII
- ;---LR*5.2*1028;01/14/11;IHS/OIT/MPW- Corrected error in next line
- ;S BLRCPTN=0 F BLRNN=1:1 S BLRCPTN=$O(^BLRCPT(BLRXII,11,BLRCPTN)) Q:'BLRCPTN S BLRCPDAT=$g(^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 BLRCPTN=0 F BLRNN=1:1 S BLRCPTN=$O(^BLRCPT(BLRXII,11,BLRCPTN)) Q:'BLRCPTN S BLRCPDAT=$G(^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_$G(^BLRCPT(BLRXII,11,BLRCPTN,2,BLRCPQN,0))
- .S:BLRNN>1 BLRCPTS=BLRCPTS_";" S BLRCPTS=BLRCPTS_BLRCPCD_"|"_BLRCPCST_"|"_BLRCPRC_"|"_BLRCPACT_"|"_BLRCPTM_"|"_BLRCPTQ
- D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("EXIT GETCPT^BLRTNA")
- K BLRCPCD,BLRCPCST,BLRCPRC,BLRCPACT,BLRCPTN,BLRCPDAT,BLRCPTM,BLRCPMN,BLRCPTQ,BLRCPQN,BLRNN,BLRNN1
- Q
- ;
- RESVRS ;EP - CALLED FROM BLRTN
- D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER RESVRS^BLRTNA")
- S BLRCREF=$P(BLRL60,U,5)
- I BLRSS=$P(BLRCREF,";"),$D(BLRRVS($P(BLRCREF,";",2))) S BLRRES=BLRRVS($P(BLRCREF,";",2)),BLRNAF=$P(BLRRES,U,2),BLRDUZ=$P(BLRRES,U,4),BLRRES=$P(BLRRES,U) D RES1
- D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("EXIT RESVRS^BLRTNA")
- Q
- ;
- RES1 ;EP - CALLED FROM BLRTN
- D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER RES1^BLRTNA")
- I BLRCMF'="C" S BLRDEL=$P($G(^BLRTXLOG(BLR("SEQUENCE NUMBER"),1)),U,2)="D" Q:BLRDEL
- I BLRSPEC'="" S BLRZ=$G(^LAB(60,BLRTEST1,1,BLRSPEC,0)) I BLRZ'="" D
- .S BLRRL=$P(BLRZ,U,2),BLRRH=$P(BLRZ,U,3),BLRUNITS=$P($P(BLRZ,U,7)," ")
- .;[LR*5.2*1028;08/20/10;IHS/OIT/MPW]Added next 1 line
- .I BLRUNITS=+BLRUNITS,$D(^BLRUCUM(BLRUNITS,0)) S BLRUNITS=$P($G(^BLRUCUM(BLRUNITS,0)),U,1)
- .S AGE=$G(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"AGE"))
- .S SEX=$G(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"SEX"))
- .X:BLRRH'?.N "S BLRRH="_BLRRH X:BLRRL'?.N "S BLRRL="_BLRRL
- .S BLR("UNITS")=BLRUNITS,BLR("REFERENCE HIGH")=BLRRH,BLR("REFERENCE LOW")=BLRRL
- .K AGE,SEX
- S BLR("RESULT")=BLRRES
- S BLR("RESULT N/A FLAG")=BLRNAF
- S BLR("STATUS FLAG")=$S(BLRRES="pending":"A",BLRRES'="":"R",1:"A") ;IHS/ITSC/TPF 08/15/01 ADDED TO HANDLE NO ANSWER FOR TEST
- S BLRDUZN=$S($D(^VA(200,BLRDUZ,0)):$P($G(^VA(200,BLRDUZ,0)),U),1:"UNK"_BLRDUZ)
- S BLR("VERIFIER POINTER")=BLRDUZ
- D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("EXIT RES1^BLRTNA")
- Q
- ;
- CRSFLDS ;EP - CALLED FROM BLRTN
- K BLR("REFERENCE HIGH"),BLR("REFERENCE LOW"),BLR("RESULT"),BLR("RESULT N/A FLAG")
- Q
- SETPRNT ;EP - CALLED BY BLRTN
- D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER SETPRNT^BLRTNA")
- K BLR
- S BLRCDT=$G(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"LRCDT"))\1
- S BLR("STATUS FLAG")="R"
- S BLRLTST=0
- F S BLRLTST=$O(^BLRTXLOG("AAT",BLRACCN,BLRLTST)) Q:'BLRLTST S BLRSEQ=0 F S BLRSEQ=$O(^BLRTXLOG("AAT",BLRACCN,BLRLTST,BLRSEQ)) Q:'BLRSEQ I $P($G(^BLRTXLOG(BLRSEQ,12)),U)\1=BLRCDT S BLRANSEQ(BLRSEQ)=""
- ;
- S BLRSEQ=""
- F S BLRSEQ=$O(BLRANSEQ(BLRSEQ),-1) Q:BLRSEQ="" S BLRDEL=$G(^BLRTXLOG(BLRSEQ,1)),BLRPAR=$P(BLRDEL,U),BLRDEL=$P(BLRDEL,U,2)="D" S:BLRPAR'="" BLRPAR(BLRPAR)=$G(BLRPAR(BLRPAR)) D
- .;A CHILD WHOSE PARENT IS DISQUALIFIED
- .;I 'BLRCMP,BLRPAR,BLRPAR(BLRPAR) Q
- .I BLRPAR,BLRPAR(BLRPAR) Q
- .;A PARENT
- .I $D(BLRPAR(BLRSEQ)) D Q
- ..;I 'BLRCMP,BLRPAR(BLRSEQ) S:BLRPAR'="" BLRPAR(BLRPAR)=1 Q
- ..I BLRPAR(BLRSEQ) S:BLRPAR'="" BLRPAR(BLRPAR)=1 Q
- ..I 'BLRDEL S BLR("SEQUENCE NUMBER")=BLRSEQ,BLRIEN=BLRSEQ_",",BLRENT=BLRSEQ,BLRENTS(1)=BLRENT D ^BLRNFLTL Q
- .;NOT A PARENT
- .I $P($G(^BLRTXLOG(BLRSEQ,20)),U)="" D Q
- ..I BLRPAR,$P($G(^LAB(60,$P($G(^BLRTXLOG(BLRSEQ,0)),U,6),0)),U,17) S BLRPAR(BLRPAR)=1 Q
- K BLRANSEQ,BLRHSEQ,BLRLSEQ,BLRLTST,BLRPAR
- D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("EXIT SETPRNT^BLRTNA")
- Q
- ;
- GETIEN() ;EP - CALLED BY BLRTN
- D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER GETIEN^BLRTNA")
- S BLRERR=0
- D
- .I BLRCMF="C" D GETNEW Q
- .S BLRCRGL="^BLRTXLOG("_BLRCRSBS_")"
- .S BLRENT=$O(@BLRCRGL@(""),BLRDIR)
- .S:'BLRENT BLRERR=1
- .I BLRENT,BLROKCK'="" D @BLROKCK
- .I 'BLRERR,BLRBADCK'="" D @BLRBADCK
- .I BLRERR D EMSG^BLRTNA Q
- .S BLRIEN=BLRENT_"," Q
- D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("EXIT GETIEN^BLRTNA")
- Q BLRENT
- ;
- GETNEW ;EP - CALLED FROM BLRTNA
- D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER GETNEW^BLRTNA")
- S BLRENT=$G(^BLRTXLOG("SEQ"))
- I 'BLRENT S BLRENT=$O(^BLRTXLOG("@"),-1) I BLRENT,'$D(^BLRTXLOG(1)) S BLRENT=0
- F BLRENT=BLRENT+1:1 Q:'$D(^BLRTXLOG(BLRENT))
- S BLRENTS="BLRENTS"
- S BLRENTS(1)=BLRENT
- S ^BLRTXLOG("SEQ")=BLRENT
- S BLRIEN="+1,"
- D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("EXIT GETNEW^BLRTNA")
- Q
- ;
- CHKDT ;EP - CALLED BY BLRTN
- D:'BLRENT EMSG^BLRTNA Q:BLRERR
- S BLRCDT=$P($G(^BLRTXLOG(BLRENT,12)),U)
- I $E(BLRCDT,1,3)=$E(DT,1,3) S BLRIEN=BLRENT_"," Q
- I ($E(BLRCDT,1,3)+1)'=$E(DT,1,3) S BLRERR=1,BLRDTER=1 Q ;MORE THAN 1 YEAR AHEAD
- I $E(BLRCDT,4,5)<11 S BLRERR=1,BLRDTER=1 Q
- S BLRIEN=BLRENT_"," Q
- Q
- ;
- CKORD ;EP - CALLED FROM BLRTN
- D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER CKORD^BLRTNA")
- S BLRERR=1
- F D Q:'BLRENT!'BLRERR
- .S BLRENT1=BLRENT
- .F Q:'$P($G(^BLRTXLOG(BLRENT1,1)),U) S BLRENT1=$P(^BLRTXLOG(BLRENT1,1),U)
- .D Q:'BLRERR
- ..I $D(LRAN) D Q
- ...I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,$P($G(^BLRTXLOG(BLRENT1,0)),U,6))) S BLRERR=0 Q
- ..I $D(^LRO(69,BLRODTM,1,BLRSEQ,2,"B",$P($G(^BLRTXLOG(BLRENT1,0)),U,6))) S BLRERR=0 Q
- .S BLRENT=$O(@BLRCRGL@(BLRENT),BLRDIR)
- D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("EXIT CKORD^BLRTNA")
- K BLRENT1
- Q
- EMSG ;EP - CALLED FROM BLRTN
- ; Log an error because the crossreference isn't set.
- I 'BLRENT D
- .S BLRERR=1,BLRERROR(1)="Something wrong -- problem with IHS Lab Transaction Log Cross Reference: "_BLRCRGL
- Q
- ;
- KILL ;EP - CALLED FROM BLRTN
- K BLR,BLRARRAY,BLREMSG,BLRENTS,BLRERR,BLRERROR,BLRFDA,BLRI,BLRICNT,BLRIEN,BLRIENS,BLRIII,BLRLOGDA,BLRQUIET,BLRSFID,BLRSIEN,BLRSTOP,BLRT,BLRTCNT,BLRVL,BLRVR,BLRVRS
- K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,BLRESTR,BLRPT,BLRXQY0,BLRPC,BLRMI,BLRDTER
- Q
- BLRTNA ;IHS/ITSC/TPF - CREATE/EDIT TRANSACTIONS [ 12/19/2002 6:40 AM ]
- +1 ;;5.2;IHS LABORATORY;**1028**;NOV 01, 1997;Build 46
- +2 ;;5.2;LR;**1013,1015**;NOV 18, 2002
- +3 ;
- CPTCODE ;EP - CALLED FROM BLRTN,BLRTNB,BLRTNM1
- +1 IF $GET(SNAPSHOT)
- DO ENTRYAUD^BLRUTIL("ENTER CPTCODE^BLRTNA")
- +2 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
- +3 IF $GET(SNAPSHOT)
- DO ENTRYAUD^BLRUTIL("EXIT CPTCODE^BLRTNA")
- +4 QUIT
- +5 ;
- GETCPT ;EP - CALLED FROM BLRTN
- +1 IF $GET(SNAPSHOT)
- DO ENTRYAUD^BLRUTIL("ENTER GETCPT^BLRTNA")
- +2 IF BLRODTM<$PIECE($GET(^BLRCPT(BLRXII,0)),U,3)
- QUIT
- +3 SET BLRFOUND=1
- SET BLRCPTP=BLRXII
- +4 ;---LR*5.2*1028;01/14/11;IHS/OIT/MPW- Corrected error in next line
- +5 ;S BLRCPTN=0 F BLRNN=1:1 S BLRCPTN=$O(^BLRCPT(BLRXII,11,BLRCPTN)) Q:'BLRCPTN S BLRCPDAT=$g(^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
- +6 SET BLRCPTN=0
- FOR BLRNN=1:1
- SET BLRCPTN=$ORDER(^BLRCPT(BLRXII,11,BLRCPTN))
- IF 'BLRCPTN
- QUIT
- SET BLRCPDAT=$GET(^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
- +7 SET (BLRCPTM,BLRCPTQ)=""
- +8 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)
- +9 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_$GET(^BLRCPT(BLRXII,11,BLRCPTN,2,BLRCPQN,0))
- +10 IF BLRNN>1
- SET BLRCPTS=BLRCPTS_";"
- SET BLRCPTS=BLRCPTS_BLRCPCD_"|"_BLRCPCST_"|"_BLRCPRC_"|"_BLRCPACT_"|"_BLRCPTM_"|"_BLRCPTQ
- End DoDot:1
- +11 IF $GET(SNAPSHOT)
- DO ENTRYAUD^BLRUTIL("EXIT GETCPT^BLRTNA")
- +12 KILL BLRCPCD,BLRCPCST,BLRCPRC,BLRCPACT,BLRCPTN,BLRCPDAT,BLRCPTM,BLRCPMN,BLRCPTQ,BLRCPQN,BLRNN,BLRNN1
- +13 QUIT
- +14 ;
- RESVRS ;EP - CALLED FROM BLRTN
- +1 IF $GET(SNAPSHOT)
- DO ENTRYAUD^BLRUTIL("ENTER RESVRS^BLRTNA")
- +2 SET BLRCREF=$PIECE(BLRL60,U,5)
- +3 IF BLRSS=$PIECE(BLRCREF,";")
- IF $DATA(BLRRVS($PIECE(BLRCREF,";",2)))
- SET BLRRES=BLRRVS($PIECE(BLRCREF,";",2))
- SET BLRNAF=$PIECE(BLRRES,U,2)
- SET BLRDUZ=$PIECE(BLRRES,U,4)
- SET BLRRES=$PIECE(BLRRES,U)
- DO RES1
- +4 IF $GET(SNAPSHOT)
- DO ENTRYAUD^BLRUTIL("EXIT RESVRS^BLRTNA")
- +5 QUIT
- +6 ;
- RES1 ;EP - CALLED FROM BLRTN
- +1 IF $GET(SNAPSHOT)
- DO ENTRYAUD^BLRUTIL("ENTER RES1^BLRTNA")
- +2 IF BLRCMF'="C"
- SET BLRDEL=$PIECE($GET(^BLRTXLOG(BLR("SEQUENCE NUMBER"),1)),U,2)="D"
- IF BLRDEL
- QUIT
- +3 IF BLRSPEC'=""
- SET BLRZ=$GET(^LAB(60,BLRTEST1,1,BLRSPEC,0))
- IF BLRZ'=""
- Begin DoDot:1
- +4 SET BLRRL=$PIECE(BLRZ,U,2)
- SET BLRRH=$PIECE(BLRZ,U,3)
- SET BLRUNITS=$PIECE($PIECE(BLRZ,U,7)," ")
- +5 ;[LR*5.2*1028;08/20/10;IHS/OIT/MPW]Added next 1 line
- +6 IF BLRUNITS=+BLRUNITS
- IF $DATA(^BLRUCUM(BLRUNITS,0))
- SET BLRUNITS=$PIECE($GET(^BLRUCUM(BLRUNITS,0)),U,1)
- +7 SET AGE=$GET(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"AGE"))
- +8 SET SEX=$GET(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"SEX"))
- +9 IF BLRRH'?.N
- XECUTE "S BLRRH="_BLRRH
- IF BLRRL'?.N
- XECUTE "S BLRRL="_BLRRL
- +10 SET BLR("UNITS")=BLRUNITS
- SET BLR("REFERENCE HIGH")=BLRRH
- SET BLR("REFERENCE LOW")=BLRRL
- +11 KILL AGE,SEX
- End DoDot:1
- +12 SET BLR("RESULT")=BLRRES
- +13 SET BLR("RESULT N/A FLAG")=BLRNAF
- +14 ;IHS/ITSC/TPF 08/15/01 ADDED TO HANDLE NO ANSWER FOR TEST
- SET BLR("STATUS FLAG")=$SELECT(BLRRES="pending":"A",BLRRES'="":"R",1:"A")
- +15 SET BLRDUZN=$SELECT($DATA(^VA(200,BLRDUZ,0)):$PIECE($GET(^VA(200,BLRDUZ,0)),U),1:"UNK"_BLRDUZ)
- +16 SET BLR("VERIFIER POINTER")=BLRDUZ
- +17 IF $GET(SNAPSHOT)
- DO ENTRYAUD^BLRUTIL("EXIT RES1^BLRTNA")
- +18 QUIT
- +19 ;
- CRSFLDS ;EP - CALLED FROM BLRTN
- +1 KILL BLR("REFERENCE HIGH"),BLR("REFERENCE LOW"),BLR("RESULT"),BLR("RESULT N/A FLAG")
- +2 QUIT
- SETPRNT ;EP - CALLED BY BLRTN
- +1 IF $GET(SNAPSHOT)
- DO ENTRYAUD^BLRUTIL("ENTER SETPRNT^BLRTNA")
- +2 KILL BLR
- +3 SET BLRCDT=$GET(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"LRCDT"))\1
- +4 SET BLR("STATUS FLAG")="R"
- +5 SET BLRLTST=0
- +6 FOR
- SET BLRLTST=$ORDER(^BLRTXLOG("AAT",BLRACCN,BLRLTST))
- IF 'BLRLTST
- QUIT
- SET BLRSEQ=0
- FOR
- SET BLRSEQ=$ORDER(^BLRTXLOG("AAT",BLRACCN,BLRLTST,BLRSEQ))
- IF 'BLRSEQ
- QUIT
- IF $PIECE($GET(^BLRTXLOG(BLRSEQ,12)),U)\1=BLRCDT
- SET BLRANSEQ(BLRSEQ)=""
- +7 ;
- +8 SET BLRSEQ=""
- +9 FOR
- SET BLRSEQ=$ORDER(BLRANSEQ(BLRSEQ),-1)
- IF BLRSEQ=""
- QUIT
- SET BLRDEL=$GET(^BLRTXLOG(BLRSEQ,1))
- SET BLRPAR=$PIECE(BLRDEL,U)
- SET BLRDEL=$PIECE(BLRDEL,U,2)="D"
- IF BLRPAR'=""
- SET BLRPAR(BLRPAR)=$GET(BLRPAR(BLRPAR))
- Begin DoDot:1
- +10 ;A CHILD WHOSE PARENT IS DISQUALIFIED
- +11 ;I 'BLRCMP,BLRPAR,BLRPAR(BLRPAR) Q
- +12 IF BLRPAR
- IF BLRPAR(BLRPAR)
- QUIT
- +13 ;A PARENT
- +14 IF $DATA(BLRPAR(BLRSEQ))
- Begin DoDot:2
- +15 ;I 'BLRCMP,BLRPAR(BLRSEQ) S:BLRPAR'="" BLRPAR(BLRPAR)=1 Q
- +16 IF BLRPAR(BLRSEQ)
- IF BLRPAR'=""
- SET BLRPAR(BLRPAR)=1
- QUIT
- +17 IF 'BLRDEL
- SET BLR("SEQUENCE NUMBER")=BLRSEQ
- SET BLRIEN=BLRSEQ_","
- SET BLRENT=BLRSEQ
- SET BLRENTS(1)=BLRENT
- DO ^BLRNFLTL
- QUIT
- End DoDot:2
- QUIT
- +18 ;NOT A PARENT
- +19 IF $PIECE($GET(^BLRTXLOG(BLRSEQ,20)),U)=""
- Begin DoDot:2
- +20 IF BLRPAR
- IF $PIECE($GET(^LAB(60,$PIECE($GET(^BLRTXLOG(BLRSEQ,0)),U,6),0)),U,17)
- SET BLRPAR(BLRPAR)=1
- QUIT
- End DoDot:2
- QUIT
- End DoDot:1
- +21 KILL BLRANSEQ,BLRHSEQ,BLRLSEQ,BLRLTST,BLRPAR
- +22 IF $GET(SNAPSHOT)
- DO ENTRYAUD^BLRUTIL("EXIT SETPRNT^BLRTNA")
- +23 QUIT
- +24 ;
- GETIEN() ;EP - CALLED BY BLRTN
- +1 IF $GET(SNAPSHOT)
- DO ENTRYAUD^BLRUTIL("ENTER GETIEN^BLRTNA")
- +2 SET BLRERR=0
- +3 Begin DoDot:1
- +4 IF BLRCMF="C"
- DO GETNEW
- QUIT
- +5 SET BLRCRGL="^BLRTXLOG("_BLRCRSBS_")"
- +6 SET BLRENT=$ORDER(@BLRCRGL@(""),BLRDIR)
- +7 IF 'BLRENT
- SET BLRERR=1
- +8 IF BLRENT
- IF BLROKCK'=""
- DO @BLROKCK
- +9 IF 'BLRERR
- IF BLRBADCK'=""
- DO @BLRBADCK
- +10 IF BLRERR
- DO EMSG^BLRTNA
- QUIT
- +11 SET BLRIEN=BLRENT_","
- QUIT
- End DoDot:1
- +12 IF $GET(SNAPSHOT)
- DO ENTRYAUD^BLRUTIL("EXIT GETIEN^BLRTNA")
- +13 QUIT BLRENT
- +14 ;
- GETNEW ;EP - CALLED FROM BLRTNA
- +1 IF $GET(SNAPSHOT)
- DO ENTRYAUD^BLRUTIL("ENTER GETNEW^BLRTNA")
- +2 SET BLRENT=$GET(^BLRTXLOG("SEQ"))
- +3 IF 'BLRENT
- SET BLRENT=$ORDER(^BLRTXLOG("@"),-1)
- IF BLRENT
- IF '$DATA(^BLRTXLOG(1))
- SET BLRENT=0
- +4 FOR BLRENT=BLRENT+1:1
- IF '$DATA(^BLRTXLOG(BLRENT))
- QUIT
- +5 SET BLRENTS="BLRENTS"
- +6 SET BLRENTS(1)=BLRENT
- +7 SET ^BLRTXLOG("SEQ")=BLRENT
- +8 SET BLRIEN="+1,"
- +9 IF $GET(SNAPSHOT)
- DO ENTRYAUD^BLRUTIL("EXIT GETNEW^BLRTNA")
- +10 QUIT
- +11 ;
- CHKDT ;EP - CALLED BY BLRTN
- +1 IF 'BLRENT
- DO EMSG^BLRTNA
- IF BLRERR
- QUIT
- +2 SET BLRCDT=$PIECE($GET(^BLRTXLOG(BLRENT,12)),U)
- +3 IF $EXTRACT(BLRCDT,1,3)=$EXTRACT(DT,1,3)
- SET BLRIEN=BLRENT_","
- QUIT
- +4 ;MORE THAN 1 YEAR AHEAD
- IF ($EXTRACT(BLRCDT,1,3)+1)'=$EXTRACT(DT,1,3)
- SET BLRERR=1
- SET BLRDTER=1
- QUIT
- +5 IF $EXTRACT(BLRCDT,4,5)<11
- SET BLRERR=1
- SET BLRDTER=1
- QUIT
- +6 SET BLRIEN=BLRENT_","
- QUIT
- +7 QUIT
- +8 ;
- CKORD ;EP - CALLED FROM BLRTN
- +1 IF $GET(SNAPSHOT)
- DO ENTRYAUD^BLRUTIL("ENTER CKORD^BLRTNA")
- +2 SET BLRERR=1
- +3 FOR
- Begin DoDot:1
- +4 SET BLRENT1=BLRENT
- +5 FOR
- IF '$PIECE($GET(^BLRTXLOG(BLRENT1,1)),U)
- QUIT
- SET BLRENT1=$PIECE(^BLRTXLOG(BLRENT1,1),U)
- +6 Begin DoDot:2
- +7 IF $DATA(LRAN)
- Begin DoDot:3
- +8 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,$PIECE($GET(^BLRTXLOG(BLRENT1,0)),U,6)))
- SET BLRERR=0
- QUIT
- End DoDot:3
- QUIT
- +9 IF $DATA(^LRO(69,BLRODTM,1,BLRSEQ,2,"B",$PIECE($GET(^BLRTXLOG(BLRENT1,0)),U,6)))
- SET BLRERR=0
- QUIT
- End DoDot:2
- IF 'BLRERR
- QUIT
- +10 SET BLRENT=$ORDER(@BLRCRGL@(BLRENT),BLRDIR)
- End DoDot:1
- IF 'BLRENT!'BLRERR
- QUIT
- +11 IF $GET(SNAPSHOT)
- DO ENTRYAUD^BLRUTIL("EXIT CKORD^BLRTNA")
- +12 KILL BLRENT1
- +13 QUIT
- EMSG ;EP - CALLED FROM BLRTN
- +1 ; Log an error because the crossreference isn't set.
- +2 IF 'BLRENT
- Begin DoDot:1
- +3 SET BLRERR=1
- SET BLRERROR(1)="Something wrong -- problem with IHS Lab Transaction Log Cross Reference: "_BLRCRGL
- End DoDot:1
- +4 QUIT
- +5 ;
- KILL ;EP - CALLED FROM BLRTN
- +1 KILL BLR,BLRARRAY,BLREMSG,BLRENTS,BLRERR,BLRERROR,BLRFDA,BLRI,BLRICNT,BLRIEN,BLRIENS,BLRIII,BLRLOGDA,BLRQUIET,BLRSFID,BLRSIEN,BLRSTOP,BLRT,BLRTCNT,BLRVL,BLRVR,BLRVRS
- +2 KILL ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,BLRESTR,BLRPT,BLRXQY0,BLRPC,BLRMI,BLRDTER
- +3 QUIT
