LRACSUM1 ;SLC/DCM - INDIVIDUAL PATIENT SUMMARY CONT. ; 10/8/87 11:14 ;
;;5.2;LAB SERVICE;**225**;Sep 27, 1994
LRIDT ;from LRACSUM
F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT<1!(LRIDT>LROUT) S X=^(LRIDT,0) D LRIIDT
Q
LRIIDT S (LRIIDT,LRVIDT)=$P(X,U,1),LRSUB=1,LRTNN=1
S LRSPM=$P(X,U,5),LRTLOC=$E($P(X,U,11),1,7),LRVDT=$P(X,U,3),LRAN=$P(X,U,6)
Q:'$L(LRVDT) D LRSUB Q
LRSUB S LRSUB=1 F S LRSUB=$O(^LR(LRDFN,"CH",LRIDT,LRSUB)) Q:LRSUB<1 S X=^(LRSUB) D SUB1
Q
SUB1 S LRTSTVAL=$P(X,U,1),X1=$P(X,U,2),LRNOFL=""
S LRTST=$O(^LAB(60,"C","CH;"_LRSUB_";"_1,0)) Q:LRTST=""
Q:"IN"[$P(^LAB(60,LRTST,0),U,3)
I '$D(^LAB(64.5,"AC",LRSUB)) D MISC Q
K LRNON D LRMH I '$D(LRNON) D MISC Q
LRMH S LRMH=0 F S LRMH=$O(^LAB(64.5,"AC",LRSUB,1,LRMH)) Q:LRMH<1 D LRSH
Q
LRSH S LRSH=0 F S LRSH=$O(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH)) Q:LRSH<1 D TST
Q
TST S LRTSTS=0 F S LRTSTS=$O(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH,LRTSTS)) Q:'LRTSTS S LRSPM1=^(LRTSTS) D TST1
Q
TST1 Q:LRSPM'=LRSPM1
SBSET S LRMHN=$P(^LAB(64.5,1,1,LRMH,0),U,1),LRTF=^(1,LRSH,0),$P(LRTF,U,4)=$P(LRTF,U,3),$P(LRTF,U,3)=$P(^(1,0),U,4),LRNON=1
;**LRTE=Total minor headings,LRMHN=Major heading name^TE^Lab performing tests,LRTF=Minor header^Profile specimen^Total tests^Type of display**
S LRIIDT=LRVIDT
S:'$D(^TMP($J,LRDFN,LRMH)) ^(LRMH)=LRMHN S:'$D(^TMP($J,LRDFN,LRMH,LRSH))!($D(^(LRSH))=10) ^(LRSH)=LRTF_U S:'$D(^TMP($J,LRDFN,LRMH,LRSH,LRIIDT,0)) ^(0)=LRTLOC_U_LRVIDT_U_LRVDT_U_LRAN_U_LRIDT
LRTSTVAL S ^TMP($J,LRDFN,LRMH,LRSH,LRIIDT,LRTSTS)=LRTSTVAL_U_X1
I $D(^LR(LRDFN,"CH",LRIDT,1,0)),'$D(^TMP($J,LRDFN,LRMH,LRSH,LRIIDT,"TX",0)) D TEXT
Q
MISC S LRTST=$O(^LAB(60,"C","CH;"_LRSUB_";"_1,0)) Q:LRTST=""
Q:"IN"[$P(^LAB(60,LRTST,0),U,3)
S LRTOP=LRSPM
S:'$D(^TMP($J,LRDFN,"MISC",LRIIDT,0)) ^(0)=LRIDT_U_LRVIDT_U_LRVDT_U_LRAN_U_LRSPM S ^(LRTNN)=LRTSTVAL_U_LRSPM_U_LRTST_U_X1_U_LRSUB
I $D(^LR(LRDFN,"CH",LRIDT,1,0)),'$D(^TMP($J,LRDFN,"MISC",LRIIDT,"TX",0)) S ^TMP($J,LRDFN,"MISC",LRIIDT,"TX",0)="" S L=0 F S L=$O(^LR(LRDFN,"CH",LRIDT,1,L)) Q:'L S ^TMP($J,LRDFN,"MISC",LRIIDT,"TX",L,0)=^LR(LRDFN,"CH",LRIDT,1,L,0)
S LRTNN=LRTNN+1
Q
TEXT S LRYESCOM=0
S M=0 F S M=$O(^LR(LRDFN,"CH",LRIDT,1,M)) Q:'M!(LRYESCOM) F N=1:1:$L(^LR(LRDFN,"CH",LRIDT,1,M,0)) Q:LRYESCOM S:$E(^(0),N)'[$C(32) LRYESCOM=1
Q:'LRYESCOM
S L=0 F S L=$O(^LR(LRDFN,"CH",LRIDT,1,L)) Q:'L S ^TMP($J,LRDFN,LRMH,LRSH,LRIIDT,"TX",L,0)=^LR(LRDFN,"CH",LRIDT,1,L,0)
Q
LRCALE ;from LRACSUM
S A7=0 F S A7=$O(^LAB(64.5,1,1,A7)) Q:A7<1 D A7
K A7,B3 Q
A7 S B3=0 F S B3=$O(^LAB(64.5,1,1,A7,1,B3)) Q:B3<1 D B3
Q
B3 S:$P(^LAB(64.5,1,1,A7,1,B3,0),U,4) LRCALE(A7,B3)=1
Q
MICRO ;from LRACSUM
Q:'$D(^LR(LRDFN,"MI")) S:'$D(LRUNKNOW) LRUNKNOW=$P(^LAB(69.9,1,1),U,5) S (LRONESPC,LRONETST)="",LREND=0
S LRWRDVEW="",LRSB=0,LRIDT=LRIN F S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT<1!(LRIDT>LROUT) S LRNLOC=LRLLOC D EN1^LRMIPC S LRLLOC=LRNLOC
K %,A,A1,AGE,B,B1,DFN,DOB,DZ,I,J,LR2ORMOR,LRAA,LRACC,LRACN,LRAD,LRADM,LRADX,LRAFS,LRAX,LRBUG,LRCMNT,LRCS,LRDCOM,LREF,LREND,LRIFN,LRLLT,LRMD,LRNLOC,LRNS,LROK,LRONESPC,LRONETST,LRORG,LRPRE,LRPRINT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRACSUM1 3111 printed Jan 18, 2025@03:07:19 Page 2
LRACSUM1 ;SLC/DCM - INDIVIDUAL PATIENT SUMMARY CONT. ; 10/8/87 11:14 ;
+1 ;;5.2;LAB SERVICE;**225**;Sep 27, 1994
LRIDT ;from LRACSUM
+1 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
if LRIDT<1!(LRIDT>LROUT)
QUIT
SET X=^(LRIDT,0)
DO LRIIDT
+2 QUIT
LRIIDT SET (LRIIDT,LRVIDT)=$PIECE(X,U,1)
SET LRSUB=1
SET LRTNN=1
+1 SET LRSPM=$PIECE(X,U,5)
SET LRTLOC=$EXTRACT($PIECE(X,U,11),1,7)
SET LRVDT=$PIECE(X,U,3)
SET LRAN=$PIECE(X,U,6)
+2 if '$LENGTH(LRVDT)
QUIT
DO LRSUB
QUIT
LRSUB SET LRSUB=1
FOR
SET LRSUB=$ORDER(^LR(LRDFN,"CH",LRIDT,LRSUB))
if LRSUB<1
QUIT
SET X=^(LRSUB)
DO SUB1
+1 QUIT
SUB1 SET LRTSTVAL=$PIECE(X,U,1)
SET X1=$PIECE(X,U,2)
SET LRNOFL=""
+1 SET LRTST=$ORDER(^LAB(60,"C","CH;"_LRSUB_";"_1,0))
if LRTST=""
QUIT
+2 if "IN"[$PIECE(^LAB(60,LRTST,0),U,3)
QUIT
+3 IF '$DATA(^LAB(64.5,"AC",LRSUB))
DO MISC
QUIT
+4 KILL LRNON
DO LRMH
IF '$DATA(LRNON)
DO MISC
QUIT
LRMH SET LRMH=0
FOR
SET LRMH=$ORDER(^LAB(64.5,"AC",LRSUB,1,LRMH))
if LRMH<1
QUIT
DO LRSH
+1 QUIT
LRSH SET LRSH=0
FOR
SET LRSH=$ORDER(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH))
if LRSH<1
QUIT
DO TST
+1 QUIT
TST SET LRTSTS=0
FOR
SET LRTSTS=$ORDER(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH,LRTSTS))
if 'LRTSTS
QUIT
SET LRSPM1=^(LRTSTS)
DO TST1
+1 QUIT
TST1 if LRSPM'=LRSPM1
QUIT
SBSET SET LRMHN=$PIECE(^LAB(64.5,1,1,LRMH,0),U,1)
SET LRTF=^(1,LRSH,0)
SET $PIECE(LRTF,U,4)=$PIECE(LRTF,U,3)
SET $PIECE(LRTF,U,3)=$PIECE(^(1,0),U,4)
SET LRNON=1
+1 ;**LRTE=Total minor headings,LRMHN=Major heading name^TE^Lab performing tests,LRTF=Minor header^Profile specimen^Total tests^Type of display**
+2 SET LRIIDT=LRVIDT
+3 if '$DATA(^TMP($JOB,LRDFN,LRMH))
SET ^(LRMH)=LRMHN
if '$DATA(^TMP($JOB,LRDFN,LRMH,LRSH))!($DATA(^(LRSH))=10)
SET ^(LRSH)=LRTF_U
if '$DATA(^TMP($JOB,LRDFN,LRMH,LRSH,LRIIDT,0))
SET ^(0)=LRTLOC_U_LRVIDT_U_LRVDT_U_LRAN_U_LRIDT
LRTSTVAL SET ^TMP($JOB,LRDFN,LRMH,LRSH,LRIIDT,LRTSTS)=LRTSTVAL_U_X1
+1 IF $DATA(^LR(LRDFN,"CH",LRIDT,1,0))
IF '$DATA(^TMP($JOB,LRDFN,LRMH,LRSH,LRIIDT,"TX",0))
DO TEXT
+2 QUIT
MISC SET LRTST=$ORDER(^LAB(60,"C","CH;"_LRSUB_";"_1,0))
if LRTST=""
QUIT
+1 if "IN"[$PIECE(^LAB(60,LRTST,0),U,3)
QUIT
+2 SET LRTOP=LRSPM
+3 if '$DATA(^TMP($JOB,LRDFN,"MISC",LRIIDT,0))
SET ^(0)=LRIDT_U_LRVIDT_U_LRVDT_U_LRAN_U_LRSPM
SET ^(LRTNN)=LRTSTVAL_U_LRSPM_U_LRTST_U_X1_U_LRSUB
+4 IF $DATA(^LR(LRDFN,"CH",LRIDT,1,0))
IF '$DATA(^TMP($JOB,LRDFN,"MISC",LRIIDT,"TX",0))
SET ^TMP($JOB,LRDFN,"MISC",LRIIDT,"TX",0)=""
SET L=0
FOR
SET L=$ORDER(^LR(LRDFN,"CH",LRIDT,1,L))
if 'L
QUIT
SET ^TMP($JOB,LRDFN,"MISC",LRIIDT,"TX",L,0)=^LR(LRDFN,"CH",LRIDT,1,L,0)
+5 SET LRTNN=LRTNN+1
+6 QUIT
TEXT SET LRYESCOM=0
+1 SET M=0
FOR
SET M=$ORDER(^LR(LRDFN,"CH",LRIDT,1,M))
if 'M!(LRYESCOM)
QUIT
FOR N=1:1:$LENGTH(^LR(LRDFN,"CH",LRIDT,1,M,0))
if LRYESCOM
QUIT
if $EXTRACT(^(0),N)'[$CHAR(32)
SET LRYESCOM=1
+2 if 'LRYESCOM
QUIT
+3 SET L=0
FOR
SET L=$ORDER(^LR(LRDFN,"CH",LRIDT,1,L))
if 'L
QUIT
SET ^TMP($JOB,LRDFN,LRMH,LRSH,LRIIDT,"TX",L,0)=^LR(LRDFN,"CH",LRIDT,1,L,0)
+4 QUIT
LRCALE ;from LRACSUM
+1 SET A7=0
FOR
SET A7=$ORDER(^LAB(64.5,1,1,A7))
if A7<1
QUIT
DO A7
+2 KILL A7,B3
QUIT
A7 SET B3=0
FOR
SET B3=$ORDER(^LAB(64.5,1,1,A7,1,B3))
if B3<1
QUIT
DO B3
+1 QUIT
B3 if $PIECE(^LAB(64.5,1,1,A7,1,B3,0),U,4)
SET LRCALE(A7,B3)=1
+1 QUIT
MICRO ;from LRACSUM
+1 if '$DATA(^LR(LRDFN,"MI"))
QUIT
if '$DATA(LRUNKNOW)
SET LRUNKNOW=$PIECE(^LAB(69.9,1,1),U,5)
SET (LRONESPC,LRONETST)=""
SET LREND=0
+2 SET LRWRDVEW=""
SET LRSB=0
SET LRIDT=LRIN
FOR
SET LRIDT=$ORDER(^LR(LRDFN,"MI",LRIDT))
if LRIDT<1!(LRIDT>LROUT)
QUIT
SET LRNLOC=LRLLOC
DO EN1^LRMIPC
SET LRLLOC=LRNLOC
+3 KILL %,A,A1,AGE,B,B1,DFN,DOB,DZ,I,J,LR2ORMOR,LRAA,LRACC,LRACN,LRAD,LRADM,LRADX,LRAFS,LRAX,LRBUG,LRCMNT,LRCS,LRDCOM,LREF,LREND,LRIFN,LRLLT,LRMD,LRNLOC,LRNS,LROK,LRONESPC,LRONETST,LRORG,LRPRE,LRPRINT
+4 QUIT
