- LR7OSUM1 ;DALOI/staff - Silent Patient cum cont. ;06/03/13 11:17
- ;;5.2;LAB SERVICE;**121,187,256,286,384,350,427**;Sep 27, 1994;Build 33
- ;
- LRIDT ; from LR7OSUM
- N GIOM,LRDRL
- S GIOM=$G(LRGIOM)
- I GIOM="" D
- . S GIOM=$$GET^XPAR("USR^DIV^PKG","LR CH GUI REPORT RIGHT MARGIN",1,"Q")
- . I GIOM="" S GIOM=80
- K ^TMP("LRPLS",$J),^TMP("LRPLS-ADDR",$J),^TMP("LRCMTINDX",$J)
- ;
- ; Flag to determine if reporting laboratory is printed on report
- S LRDRL=$$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")#2
- ;
- F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT<1!(LRIDT>LROUT)!(CT1>COUNT) I $D(^(LRIDT,0)) S X=^(0),CT1=CT1+1 D LRIIDT
- D CMTINDX^LR7OSUM2
- Q
- ;
- ;
- LRIIDT ;
- N LRIIDT,LRAN,LRPROV,LREAL,LRSPM,LRSPM1,LRSUB,LRTLOC,LRTNN,LRTST,LRTSTS,LRVDT,LRVIDT
- S (LRIIDT,LRVIDT)=$P(X,U,1),LREAL=$P(X,U,2),LRSUB=1,LRTNN=1,LRSPM=$P(X,U,5),LRTLOC=$E($P(X,U,11),1,7),LRVDT=$P(X,U,3),LRAN=$P(X,U,6),LRPROV=$P(X,U,10)
- ;
- I LRVDT D Q
- . D LRSUB,ORDBY^LR7OSUM2,RELDT^LR7OSUM2
- . I LRDRL D RL^LR7OSUM2
- . D PLS^LR7OSUM2
- ;
- I LRVDT="" D
- . D CHKNP,ORDBY^LR7OSUM2
- . I LRDRL D RL^LR7OSUM2
- . N OUTCNT
- . S OUTCNT=+$O(^TMP($J,LRDFN,"MISC",LRIDT,"TX",9999999),-1),OUTCNT=OUTCNT+1
- . S ^TMP($J,LRDFN,"MISC",LRIDT,"TX",OUTCNT,0)=" "
- ;
- Q
- ;
- ;
- LRSUB ;
- N LRTRES
- S LRSUB=1
- F S LRSUB=$O(^LR(LRDFN,"CH",LRIDT,LRSUB)) Q:LRSUB<1 D
- . S X=^LR(LRDFN,"CH",LRIDT,LRSUB)
- . S LRTRES=$$TSTRES^LRRPU(LRDFN,"CH",LRIDT,LRSUB,"")
- . I $P(LRTRES,"^",1)="" Q
- . D SUB1
- Q
- ;
- ;
- SUB1 ;
- N LRNOFL,LRTSTVAL
- S LRTSTVAL=$P(LRTRES,U,1)
- S LRNOFL="",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 ;
- N LRMHN,LRTF
- 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
- Q:$S('$D(SUBHEAD):0,1:'$D(SUBHEAD($P(LRTF,"^"))))
- ;
- ;** 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,LRIDT,0)) ^(0)=LRTLOC_U_LRVIDT_U_LRVDT_U_LRAN_U_LRIDT_U_LREAL
- ;
- LRTSTVAL ;
- ;
- N TST
- S ^TMP($J,LRDFN,LRMH,LRSH,LRIDT,LRTSTS)=$P(LRTRES,"^")_"^"_$P(LRTRES,"^",2)
- S X=$P($G(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRTSTS,0)),"^",3)
- I X'="" S ^TMP("LRT",$J,X)=$P(LRTF,"^")
- ;
- ; Check for comment on specimen and put in TMP global on first pass
- I $D(^LR(LRDFN,"CH",LRIDT,1,0)),'$D(^TMP($J,LRDFN,LRMH,LRSH,LRIDT,"TX",0)) D TEXT
- ;
- ; Check if individual result's unit/normals different from test units/normals
- I $P(LRTRES,"^")'?1(1"pending",1"comment",1"canc") D CHKUN
- ;
- S TST=$S($P($G(^LAB(60,LRTST,.1)),"^")'="":$P(^(.1),"^"),1:$P(^LAB(60,LRTST,0),"^"))
- I $O(^LAB(60,LRTST,1,LRSPM,1,0)),'$D(^TMP($J,"EVAL",LRTST,LRSPM)) D
- . S ^TMP($J,"EVAL",LRTST,LRSPM)=""
- . N I,L,X
- . S I=0
- . S L=+$O(^TMP($J,LRDFN,LRMH,LRSH,LRIDT,"TX",9999999),-1),L=L+1,^TMP($J,LRDFN,LRMH,LRSH,LRIDT,"TX",L,0)="Evaluation for "_TST_":"
- . F S I=$O(^LAB(60,LRTST,1,LRSPM,1,I)) Q:'I S X=^(I,0) S L=L+1,^TMP($J,LRDFN,LRMH,LRSH,LRIDT,"TX",L,0)=X
- . S ^TMP("LRCMTINDX",$J,LRIDT)=""
- ;
- ; Save performing lab ien in list
- I $P(LRTRES,U,6) S ^TMP("LRPLS",$J,LRMH,LRSH,$P(LRTRES,U,6),TST)="",^TMP("LRCMTINDX",$J,LRIDT)=""
- Q
- ;
- ;
- MISC ;
- Q:$S('$D(SUBHEAD):0,1:'$D(SUBHEAD("MISCELLANEOUS TESTS")))
- S LRTST=$O(^LAB(60,"C","CH;"_LRSUB_";"_1,0))
- Q:LRTST=""
- Q:"IN"[$P(^LAB(60,LRTST,0),U,3)
- N LRTOP,TST
- S LRTOP=LRSPM
- ;
- S:'$D(^TMP($J,LRDFN,"MISC",LRIDT,0)) ^(0)=LRIDT_U_LRVIDT_U_LRVDT_U_LRAN_U_LRSPM_U_LREAL
- S ^TMP($J,LRDFN,"MISC",LRIDT,LRTNN)=$P(LRTRES,"^")_U_LRSPM_U_LRTST_U_$P(LRTRES,"^",2)_U_LRSUB_U_$P(LRTRES,"^",3,6)
- ;
- S TST=$P($G(^LAB(60,LRTST,.1)),"^")
- I TST="" S TST=$P(^LAB(60,LRTST,0),"^")
- S ^TMP("LRT",$J,TST)="MISCELLANEOUS TESTS"
- ;
- ; Grab specimen comments
- D GSC
- ;
- ; Grab test interpretation
- I $O(^LAB(60,LRTST,1,LRSPM,1,0)) D
- . N I,L,X
- . S I=0
- . S:'$D(^TMP($J,LRDFN,"MISC",LRIDT,"TX",0)) ^TMP($J,LRDFN,"MISC",LRIDT,"TX",0)=""
- . S L=+$O(^TMP($J,LRDFN,"MISC",LRIDT,"TX",9999999),-1),L=L+1
- . S ^TMP($J,LRDFN,"MISC",LRIDT,"TX",L,0)="Evaluation for "_TST_":"
- . F S I=$O(^LAB(60,LRTST,1,LRSPM,1,I)) Q:'I S X=^(I,0) S L=L+1,^TMP($J,LRDFN,"MISC",LRIDT,"TX",L,0)=X
- ;
- ; Save performing lab ien in list
- I $P(LRTRES,U,6) S ^TMP("LRPLS",$J,"MISC",$P(LRTRES,U,6),TST)=""
- ;
- S LRTNN=LRTNN+1
- Q
- ;
- ;
- TEXT ;
- N LRYESCOM,M,N
- S LRYESCOM=0
- S M=0
- F S M=$O(^LR(LRDFN,"CH",LRIDT,1,M)) Q:M<1!(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<1 S ^TMP($J,LRDFN,LRMH,LRSH,LRIDT,"TX",L,0)=^LR(LRDFN,"CH",LRIDT,1,L,0)
- S ^TMP("LRCMTINDX",$J,LRIDT)=""
- Q
- ;
- ;
- MICRO ;from LR7OSUM
- Q:'$D(^LR(LRDFN,"MI"))
- N GIOM,MICROCNT
- S GIOM=$G(LRGIOM)
- I GIOM="" D
- . S GIOM=$$GET^XPAR("USR^DIV^PKG","LR MI GUI REPORT RIGHT MARGIN",1,"Q")
- . I GIOM="" S GIOM=80
- S:'$D(LRUNKNOW) LRUNKNOW=$P(^LAB(69.9,1,1),U,5)
- S (LRONESPC,LRONETST)="",LREND=0,MICROCNT=GCNT+1
- I $O(^LR(LRDFN,"MI",0)) S ^TMP("LRH",$J,"MICROBIOLOGY")=MICROCNT
- S LRWRDVEW="",LRSB=0,LRIDT=LRIN
- F S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT<1!(LRIDT>LROUT)!(CT1>COUNT) D
- . N LRX
- . ;
- . S LRNLOC=LRLLOC
- . S CT1=CT1+1
- . ;
- . D EN1^LR7OSMZ0
- . ;
- . D LN^LR7OSMZ1
- . S LRX="=",^TMP("LRC",$J,GCNT,0)=$$REPEAT^XLFSTR(LRX,GIOM/$L(LRX))
- . D LN^LR7OSMZ1
- . S ^TMP("LRC",$J,GCNT,0)=""
- . ;
- . S LRLLOC=LRNLOC
- I GCNT'>MICROCNT K ^TMP("LRH",$J,"MICROBIOLOGY")
- 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
- ;
- ;
- CHKUN ; Check units and normals with cumulative report values
- ; Add comment if these differ from file #64.5 values
- ;
- N I,L,LRFLAG,LRHI,LRLO,LRLOHI,LRX,LRY,TST,TXT
- S LRX=$G(^LAB(64.5,"A",1,LRMH,LRSH,LRTSTS)),LRFLAG=0
- S TST=$P($G(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRTSTS,0)),"^",3)
- S LRY="*** For test "_TST
- ; Check units - if different generate comment
- I $$UP^XLFSTR($P(LRX,"^",7))'=$$UP^XLFSTR($P(LRTRES,"^",5)) S LRY=LRY_" Units: "_$S($P(LRTRES,"^",5)'="":$P(LRTRES,"^",5),1:"<none specified>"),LRFLAG=1
- ;
- ; Check normals - if different generate comment
- S @("LRLO="_$S($P(LRX,"^",2)'="":$P(LRX,"^",2),$P(LRX,"^",11)'="":$P(LRX,"^",11),1:""""""))
- ;
- S @("LRHI="_$S($P(LRX,"^",3)'="":$P(LRX,"^",3),$P(LRX,"^",12)'="":$P(LRX,"^",12),1:""""""))
- I LRLO'=$P(LRTRES,"^",3)!(LRHI'=$P(LRTRES,"^",4)) D
- . I '$$REALDIFF Q
- . I LRFLAG S LRY=LRY_" and"
- . S TXT=""
- . D
- . . I $P(LRTRES,"^",3)="",$P(LRTRES,"^",4)="" S TXT="<none specified>" Q
- . . I $P(LRTRES,"^",3)'="",$P(LRTRES,"^",4)'="" S TXT=$P(LRTRES,"^",3)_" to "_$P(LRTRES,"^",4) Q
- . . I $P(LRTRES,"^",3)'="",$P(LRTRES,"^",4)="" S TXT=$S($P(LRTRES,"^",3)?.AP:$P(LRTRES,"^",3),1:"low: "_$P(LRTRES,"^",3)) Q
- . . I $P(LRTRES,"^",3)="",$P(LRTRES,"^",4)'="" S TXT=$S($P(LRTRES,"^",4)?.AP:$P(LRTRES,"^",4),1:"high: "_$P(LRTRES,"^",4)) Q
- . I TXT'="" S LRY=LRY_" Normals: "_TXT,LRFLAG=1
- ;
- I 'LRFLAG Q
- ;
- S L=+$O(^TMP($J,LRDFN,LRMH,LRSH,LRIDT,"TX",9999999),-1),L=L+1
- S LRY=LRY_" ***",^TMP($J,LRDFN,LRMH,LRSH,LRIDT,"TX",L,0)=LRY
- S ^TMP("LRCMTINDX",$J,LRIDT)=""
- Q
- ;
- ;
- REALDIFF() ;
- ; function to determine if values are numeric and are different
- ; solely because of leading or trailing zeroes
- ; returns 0 if difference is because of leading/trailing zeroes
- ; returns 1 if differences are meaningful
- N LRTRESLO,LRTRESHI,DIFF
- S LRTRESLO=$P(LRTRES,"^",3),LRTRESHI=$P(LRTRES,"^",4)
- S DIFF=0
- I LRLO'=LRTRESLO S DIFF=1 D
- . I LRLO?.N!(LRLO?.N1".".N) D
- . . I LRTRESLO?.N!(LRTRESLO?.N1".".N) D
- . . . I +LRLO=+LRTRESLO S DIFF=0
- I DIFF Q 1
- I LRHI'=LRTRESHI S DIFF=1 D
- . I LRHI?.N!(LRHI?.N1".".N) D
- . . I LRTRESHI?.N!(LRTRESHI?.N1".".N) D
- . . . I +LRHI=+LRTRESHI S DIFF=0
- I DIFF Q 1
- Q 0
- ;
- ;
- GSC ; Grab specimen comments
- ;
- I $D(^LR(LRDFN,"CH",LRIDT,1,0)),'$D(^TMP($J,LRDFN,"MISC",LRIDT,"TX",0)) D
- . S ^TMP($J,LRDFN,"MISC",LRIDT,"TX",0)="",L=0
- . F S L=$O(^LR(LRDFN,"CH",LRIDT,1,L)) Q:L<1 S ^TMP($J,LRDFN,"MISC",LRIDT,"TX",L,0)=^LR(LRDFN,"CH",LRIDT,1,L,0)
- ;
- Q
- ;
- ;
- CHKNP ; Check for NP comments and no verified results.
- ;
- ;
- N LRCAN,TST
- ; Don't print unverified results.
- I $O(^LR(LRDFN,"CH",LRIDT,1)) Q
- ;
- S LRCAN=0
- F S LRCAN=+$O(^LR(LRDFN,"CH",LRIDT,1,LRCAN)) Q:LRCAN<1 Q:($E(^(LRCAN,0))="*")
- ;
- ; Print if cancel comment and no unverified results.
- I LRCAN<1 Q
- ;
- Q:$S('$D(SUBHEAD):0,1:'$D(SUBHEAD("MISCELLANEOUS TESTS")))
- ;
- S:'$D(^TMP($J,LRDFN,"MISC",LRIDT,0)) ^(0)=LRIDT_U_LRVIDT_U_LRVDT_U_LRAN_U_LRSPM_U_LREAL
- S ^TMP($J,LRDFN,"MISC",LRIDT,LRTNN)=""_U_LRSPM_U
- ;
- S TST="See comment"
- S ^TMP("LRT",$J,TST)="MISCELLANEOUS TESTS"
- ;
- ; Grab specimen comments
- D GSC
- ;
- S LRTNN=LRTNN+1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OSUM1 9489 printed Feb 18, 2025@23:31:35 Page 2
- LR7OSUM1 ;DALOI/staff - Silent Patient cum cont. ;06/03/13 11:17
- +1 ;;5.2;LAB SERVICE;**121,187,256,286,384,350,427**;Sep 27, 1994;Build 33
- +2 ;
- LRIDT ; from LR7OSUM
- +1 NEW GIOM,LRDRL
- +2 SET GIOM=$GET(LRGIOM)
- +3 IF GIOM=""
- Begin DoDot:1
- +4 SET GIOM=$$GET^XPAR("USR^DIV^PKG","LR CH GUI REPORT RIGHT MARGIN",1,"Q")
- +5 IF GIOM=""
- SET GIOM=80
- End DoDot:1
- +6 KILL ^TMP("LRPLS",$JOB),^TMP("LRPLS-ADDR",$JOB),^TMP("LRCMTINDX",$JOB)
- +7 ;
- +8 ; Flag to determine if reporting laboratory is printed on report
- +9 SET LRDRL=$$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")#2
- +10 ;
- +11 FOR
- SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
- if LRIDT<1!(LRIDT>LROUT)!(CT1>COUNT)
- QUIT
- IF $DATA(^(LRIDT,0))
- SET X=^(0)
- SET CT1=CT1+1
- DO LRIIDT
- +12 DO CMTINDX^LR7OSUM2
- +13 QUIT
- +14 ;
- +15 ;
- LRIIDT ;
- +1 NEW LRIIDT,LRAN,LRPROV,LREAL,LRSPM,LRSPM1,LRSUB,LRTLOC,LRTNN,LRTST,LRTSTS,LRVDT,LRVIDT
- +2 SET (LRIIDT,LRVIDT)=$PIECE(X,U,1)
- SET LREAL=$PIECE(X,U,2)
- SET LRSUB=1
- SET LRTNN=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)
- SET LRPROV=$PIECE(X,U,10)
- +3 ;
- +4 IF LRVDT
- Begin DoDot:1
- +5 DO LRSUB
- DO ORDBY^LR7OSUM2
- DO RELDT^LR7OSUM2
- +6 IF LRDRL
- DO RL^LR7OSUM2
- +7 DO PLS^LR7OSUM2
- End DoDot:1
- QUIT
- +8 ;
- +9 IF LRVDT=""
- Begin DoDot:1
- +10 DO CHKNP
- DO ORDBY^LR7OSUM2
- +11 IF LRDRL
- DO RL^LR7OSUM2
- +12 NEW OUTCNT
- +13 SET OUTCNT=+$ORDER(^TMP($JOB,LRDFN,"MISC",LRIDT,"TX",9999999),-1)
- SET OUTCNT=OUTCNT+1
- +14 SET ^TMP($JOB,LRDFN,"MISC",LRIDT,"TX",OUTCNT,0)=" "
- End DoDot:1
- +15 ;
- +16 QUIT
- +17 ;
- +18 ;
- LRSUB ;
- +1 NEW LRTRES
- +2 SET LRSUB=1
- +3 FOR
- SET LRSUB=$ORDER(^LR(LRDFN,"CH",LRIDT,LRSUB))
- if LRSUB<1
- QUIT
- Begin DoDot:1
- +4 SET X=^LR(LRDFN,"CH",LRIDT,LRSUB)
- +5 SET LRTRES=$$TSTRES^LRRPU(LRDFN,"CH",LRIDT,LRSUB,"")
- +6 IF $PIECE(LRTRES,"^",1)=""
- QUIT
- +7 DO SUB1
- End DoDot:1
- +8 QUIT
- +9 ;
- +10 ;
- SUB1 ;
- +1 NEW LRNOFL,LRTSTVAL
- +2 SET LRTSTVAL=$PIECE(LRTRES,U,1)
- +3 SET LRNOFL=""
- SET LRTST=$ORDER(^LAB(60,"C","CH;"_LRSUB_";"_1,0))
- +4 if LRTST=""
- QUIT
- +5 if "IN"[$PIECE(^LAB(60,LRTST,0),U,3)
- QUIT
- +6 IF '$DATA(^LAB(64.5,"AC",LRSUB))
- DO MISC
- QUIT
- +7 KILL LRNON
- +8 DO LRMH
- +9 IF '$DATA(LRNON)
- DO MISC
- +10 QUIT
- +11 ;
- +12 ;
- LRMH ;
- +1 SET LRMH=0
- +2 FOR
- SET LRMH=$ORDER(^LAB(64.5,"AC",LRSUB,1,LRMH))
- if LRMH<1
- QUIT
- DO LRSH
- +3 QUIT
- +4 ;
- +5 ;
- LRSH ;
- +1 SET LRSH=0
- +2 FOR
- SET LRSH=$ORDER(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH))
- if LRSH<1
- QUIT
- DO TST
- +3 QUIT
- +4 ;
- +5 ;
- TST ;
- +1 SET LRTSTS=0
- +2 FOR
- SET LRTSTS=$ORDER(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH,LRTSTS))
- if 'LRTSTS
- QUIT
- SET LRSPM1=^(LRTSTS)
- DO TST1
- +3 QUIT
- +4 ;
- +5 ;
- TST1 ;
- +1 if LRSPM'=LRSPM1
- QUIT
- +2 ;
- SBSET ;
- +1 NEW LRMHN,LRTF
- +2 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
- +3 if $SELECT('$DATA(SUBHEAD)
- QUIT
- +4 ;
- +5 ;** LRTE=Total minor headings
- +6 ;** LRMHN=Major heading name^TE^Lab performing tests
- +7 ;** LRTF=Minor header^Profile specimen^Total tests^Type of display
- +8 ;
- +9 SET LRIIDT=LRVIDT
- +10 if '$DATA(^TMP($JOB,LRDFN,LRMH))
- SET ^(LRMH)=LRMHN
- +11 if '$DATA(^TMP($JOB,LRDFN,LRMH,LRSH))!($DATA(^(LRSH))=10)
- SET ^(LRSH)=LRTF_U
- +12 if '$DATA(^TMP($JOB,LRDFN,LRMH,LRSH,LRIDT,0))
- SET ^(0)=LRTLOC_U_LRVIDT_U_LRVDT_U_LRAN_U_LRIDT_U_LREAL
- +13 ;
- LRTSTVAL ;
- +1 ;
- +2 NEW TST
- +3 SET ^TMP($JOB,LRDFN,LRMH,LRSH,LRIDT,LRTSTS)=$PIECE(LRTRES,"^")_"^"_$PIECE(LRTRES,"^",2)
- +4 SET X=$PIECE($GET(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRTSTS,0)),"^",3)
- +5 IF X'=""
- SET ^TMP("LRT",$JOB,X)=$PIECE(LRTF,"^")
- +6 ;
- +7 ; Check for comment on specimen and put in TMP global on first pass
- +8 IF $DATA(^LR(LRDFN,"CH",LRIDT,1,0))
- IF '$DATA(^TMP($JOB,LRDFN,LRMH,LRSH,LRIDT,"TX",0))
- DO TEXT
- +9 ;
- +10 ; Check if individual result's unit/normals different from test units/normals
- +11 IF $PIECE(LRTRES,"^")'?1(1"pending",1"comment",1"canc")
- DO CHKUN
- +12 ;
- +13 SET TST=$SELECT($PIECE($GET(^LAB(60,LRTST,.1)),"^")'="":$PIECE(^(.1),"^"),1:$PIECE(^LAB(60,LRTST,0),"^"))
- +14 IF $ORDER(^LAB(60,LRTST,1,LRSPM,1,0))
- IF '$DATA(^TMP($JOB,"EVAL",LRTST,LRSPM))
- Begin DoDot:1
- +15 SET ^TMP($JOB,"EVAL",LRTST,LRSPM)=""
- +16 NEW I,L,X
- +17 SET I=0
- +18 SET L=+$ORDER(^TMP($JOB,LRDFN,LRMH,LRSH,LRIDT,"TX",9999999),-1)
- SET L=L+1
- SET ^TMP($JOB,LRDFN,LRMH,LRSH,LRIDT,"TX",L,0)="Evaluation for "_TST_":"
- +19 FOR
- SET I=$ORDER(^LAB(60,LRTST,1,LRSPM,1,I))
- if 'I
- QUIT
- SET X=^(I,0)
- SET L=L+1
- SET ^TMP($JOB,LRDFN,LRMH,LRSH,LRIDT,"TX",L,0)=X
- +20 SET ^TMP("LRCMTINDX",$JOB,LRIDT)=""
- End DoDot:1
- +21 ;
- +22 ; Save performing lab ien in list
- +23 IF $PIECE(LRTRES,U,6)
- SET ^TMP("LRPLS",$JOB,LRMH,LRSH,$PIECE(LRTRES,U,6),TST)=""
- SET ^TMP("LRCMTINDX",$JOB,LRIDT)=""
- +24 QUIT
- +25 ;
- +26 ;
- MISC ;
- +1 if $SELECT('$DATA(SUBHEAD)
- QUIT
- +2 SET LRTST=$ORDER(^LAB(60,"C","CH;"_LRSUB_";"_1,0))
- +3 if LRTST=""
- QUIT
- +4 if "IN"[$PIECE(^LAB(60,LRTST,0),U,3)
- QUIT
- +5 NEW LRTOP,TST
- +6 SET LRTOP=LRSPM
- +7 ;
- +8 if '$DATA(^TMP($JOB,LRDFN,"MISC",LRIDT,0))
- SET ^(0)=LRIDT_U_LRVIDT_U_LRVDT_U_LRAN_U_LRSPM_U_LREAL
- +9 SET ^TMP($JOB,LRDFN,"MISC",LRIDT,LRTNN)=$PIECE(LRTRES,"^")_U_LRSPM_U_LRTST_U_$PIECE(LRTRES,"^",2)_U_LRSUB_U_$PIECE(LRTRES,"^",3,6)
- +10 ;
- +11 SET TST=$PIECE($GET(^LAB(60,LRTST,.1)),"^")
- +12 IF TST=""
- SET TST=$PIECE(^LAB(60,LRTST,0),"^")
- +13 SET ^TMP("LRT",$JOB,TST)="MISCELLANEOUS TESTS"
- +14 ;
- +15 ; Grab specimen comments
- +16 DO GSC
- +17 ;
- +18 ; Grab test interpretation
- +19 IF $ORDER(^LAB(60,LRTST,1,LRSPM,1,0))
- Begin DoDot:1
- +20 NEW I,L,X
- +21 SET I=0
- +22 if '$DATA(^TMP($JOB,LRDFN,"MISC",LRIDT,"TX",0))
- SET ^TMP($JOB,LRDFN,"MISC",LRIDT,"TX",0)=""
- +23 SET L=+$ORDER(^TMP($JOB,LRDFN,"MISC",LRIDT,"TX",9999999),-1)
- SET L=L+1
- +24 SET ^TMP($JOB,LRDFN,"MISC",LRIDT,"TX",L,0)="Evaluation for "_TST_":"
- +25 FOR
- SET I=$ORDER(^LAB(60,LRTST,1,LRSPM,1,I))
- if 'I
- QUIT
- SET X=^(I,0)
- SET L=L+1
- SET ^TMP($JOB,LRDFN,"MISC",LRIDT,"TX",L,0)=X
- End DoDot:1
- +26 ;
- +27 ; Save performing lab ien in list
- +28 IF $PIECE(LRTRES,U,6)
- SET ^TMP("LRPLS",$JOB,"MISC",$PIECE(LRTRES,U,6),TST)=""
- +29 ;
- +30 SET LRTNN=LRTNN+1
- +31 QUIT
- +32 ;
- +33 ;
- TEXT ;
- +1 NEW LRYESCOM,M,N
- +2 SET LRYESCOM=0
- +3 SET M=0
- +4 FOR
- SET M=$ORDER(^LR(LRDFN,"CH",LRIDT,1,M))
- if M<1!(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
- +5 if 'LRYESCOM
- QUIT
- +6 SET L=0
- +7 FOR
- SET L=$ORDER(^LR(LRDFN,"CH",LRIDT,1,L))
- if L<1
- QUIT
- SET ^TMP($JOB,LRDFN,LRMH,LRSH,LRIDT,"TX",L,0)=^LR(LRDFN,"CH",LRIDT,1,L,0)
- +8 SET ^TMP("LRCMTINDX",$JOB,LRIDT)=""
- +9 QUIT
- +10 ;
- +11 ;
- MICRO ;from LR7OSUM
- +1 if '$DATA(^LR(LRDFN,"MI"))
- QUIT
- +2 NEW GIOM,MICROCNT
- +3 SET GIOM=$GET(LRGIOM)
- +4 IF GIOM=""
- Begin DoDot:1
- +5 SET GIOM=$$GET^XPAR("USR^DIV^PKG","LR MI GUI REPORT RIGHT MARGIN",1,"Q")
- +6 IF GIOM=""
- SET GIOM=80
- End DoDot:1
- +7 if '$DATA(LRUNKNOW)
- SET LRUNKNOW=$PIECE(^LAB(69.9,1,1),U,5)
- +8 SET (LRONESPC,LRONETST)=""
- SET LREND=0
- SET MICROCNT=GCNT+1
- +9 IF $ORDER(^LR(LRDFN,"MI",0))
- SET ^TMP("LRH",$JOB,"MICROBIOLOGY")=MICROCNT
- +10 SET LRWRDVEW=""
- SET LRSB=0
- SET LRIDT=LRIN
- +11 FOR
- SET LRIDT=$ORDER(^LR(LRDFN,"MI",LRIDT))
- if LRIDT<1!(LRIDT>LROUT)!(CT1>COUNT)
- QUIT
- Begin DoDot:1
- +12 NEW LRX
- +13 ;
- +14 SET LRNLOC=LRLLOC
- +15 SET CT1=CT1+1
- +16 ;
- +17 DO EN1^LR7OSMZ0
- +18 ;
- +19 DO LN^LR7OSMZ1
- +20 SET LRX="="
- SET ^TMP("LRC",$JOB,GCNT,0)=$$REPEAT^XLFSTR(LRX,GIOM/$LENGTH(LRX))
- +21 DO LN^LR7OSMZ1
- +22 SET ^TMP("LRC",$JOB,GCNT,0)=""
- +23 ;
- +24 SET LRLLOC=LRNLOC
- End DoDot:1
- +25 IF GCNT'>MICROCNT
- KILL ^TMP("LRH",$JOB,"MICROBIOLOGY")
- +26 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
- +27 QUIT
- +28 ;
- +29 ;
- CHKUN ; Check units and normals with cumulative report values
- +1 ; Add comment if these differ from file #64.5 values
- +2 ;
- +3 NEW I,L,LRFLAG,LRHI,LRLO,LRLOHI,LRX,LRY,TST,TXT
- +4 SET LRX=$GET(^LAB(64.5,"A",1,LRMH,LRSH,LRTSTS))
- SET LRFLAG=0
- +5 SET TST=$PIECE($GET(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRTSTS,0)),"^",3)
- +6 SET LRY="*** For test "_TST
- +7 ; Check units - if different generate comment
- +8 IF $$UP^XLFSTR($PIECE(LRX,"^",7))'=$$UP^XLFSTR($PIECE(LRTRES,"^",5))
- SET LRY=LRY_" Units: "_$SELECT($PIECE(LRTRES,"^",5)'="":$PIECE(LRTRES,"^",5),1:"<none specified>")
- SET LRFLAG=1
- +9 ;
- +10 ; Check normals - if different generate comment
- +11 SET @("LRLO="_$SELECT($PIECE(LRX,"^",2)'="":$PIECE(LRX,"^",2),$PIECE(LRX,"^",11)'="":$PIECE(LRX,"^",11),1:""""""))
- +12 ;
- +13 SET @("LRHI="_$SELECT($PIECE(LRX,"^",3)'="":$PIECE(LRX,"^",3),$PIECE(LRX,"^",12)'="":$PIECE(LRX,"^",12),1:""""""))
- +14 IF LRLO'=$PIECE(LRTRES,"^",3)!(LRHI'=$PIECE(LRTRES,"^",4))
- Begin DoDot:1
- +15 IF '$$REALDIFF
- QUIT
- +16 IF LRFLAG
- SET LRY=LRY_" and"
- +17 SET TXT=""
- +18 Begin DoDot:2
- +19 IF $PIECE(LRTRES,"^",3)=""
- IF $PIECE(LRTRES,"^",4)=""
- SET TXT="<none specified>"
- QUIT
- +20 IF $PIECE(LRTRES,"^",3)'=""
- IF $PIECE(LRTRES,"^",4)'=""
- SET TXT=$PIECE(LRTRES,"^",3)_" to "_$PIECE(LRTRES,"^",4)
- QUIT
- +21 IF $PIECE(LRTRES,"^",3)'=""
- IF $PIECE(LRTRES,"^",4)=""
- SET TXT=$SELECT($PIECE(LRTRES,"^",3)?.AP:$PIECE(LRTRES,"^",3),1:"low: "_$PIECE(LRTRES,"^",3))
- QUIT
- +22 IF $PIECE(LRTRES,"^",3)=""
- IF $PIECE(LRTRES,"^",4)'=""
- SET TXT=$SELECT($PIECE(LRTRES,"^",4)?.AP:$PIECE(LRTRES,"^",4),1:"high: "_$PIECE(LRTRES,"^",4))
- QUIT
- End DoDot:2
- +23 IF TXT'=""
- SET LRY=LRY_" Normals: "_TXT
- SET LRFLAG=1
- End DoDot:1
- +24 ;
- +25 IF 'LRFLAG
- QUIT
- +26 ;
- +27 SET L=+$ORDER(^TMP($JOB,LRDFN,LRMH,LRSH,LRIDT,"TX",9999999),-1)
- SET L=L+1
- +28 SET LRY=LRY_" ***"
- SET ^TMP($JOB,LRDFN,LRMH,LRSH,LRIDT,"TX",L,0)=LRY
- +29 SET ^TMP("LRCMTINDX",$JOB,LRIDT)=""
- +30 QUIT
- +31 ;
- +32 ;
- REALDIFF() ;
- +1 ; function to determine if values are numeric and are different
- +2 ; solely because of leading or trailing zeroes
- +3 ; returns 0 if difference is because of leading/trailing zeroes
- +4 ; returns 1 if differences are meaningful
- +5 NEW LRTRESLO,LRTRESHI,DIFF
- +6 SET LRTRESLO=$PIECE(LRTRES,"^",3)
- SET LRTRESHI=$PIECE(LRTRES,"^",4)
- +7 SET DIFF=0
- +8 IF LRLO'=LRTRESLO
- SET DIFF=1
- Begin DoDot:1
- +9 IF LRLO?.N!(LRLO?.N1".".N)
- Begin DoDot:2
- +10 IF LRTRESLO?.N!(LRTRESLO?.N1".".N)
- Begin DoDot:3
- +11 IF +LRLO=+LRTRESLO
- SET DIFF=0
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +12 IF DIFF
- QUIT 1
- +13 IF LRHI'=LRTRESHI
- SET DIFF=1
- Begin DoDot:1
- +14 IF LRHI?.N!(LRHI?.N1".".N)
- Begin DoDot:2
- +15 IF LRTRESHI?.N!(LRTRESHI?.N1".".N)
- Begin DoDot:3
- +16 IF +LRHI=+LRTRESHI
- SET DIFF=0
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +17 IF DIFF
- QUIT 1
- +18 QUIT 0
- +19 ;
- +20 ;
- GSC ; Grab specimen comments
- +1 ;
- +2 IF $DATA(^LR(LRDFN,"CH",LRIDT,1,0))
- IF '$DATA(^TMP($JOB,LRDFN,"MISC",LRIDT,"TX",0))
- Begin DoDot:1
- +3 SET ^TMP($JOB,LRDFN,"MISC",LRIDT,"TX",0)=""
- SET L=0
- +4 FOR
- SET L=$ORDER(^LR(LRDFN,"CH",LRIDT,1,L))
- if L<1
- QUIT
- SET ^TMP($JOB,LRDFN,"MISC",LRIDT,"TX",L,0)=^LR(LRDFN,"CH",LRIDT,1,L,0)
- End DoDot:1
- +5 ;
- +6 QUIT
- +7 ;
- +8 ;
- CHKNP ; Check for NP comments and no verified results.
- +1 ;
- +2 ;
- +3 NEW LRCAN,TST
- +4 ; Don't print unverified results.
- +5 IF $ORDER(^LR(LRDFN,"CH",LRIDT,1))
- QUIT
- +6 ;
- +7 SET LRCAN=0
- +8 FOR
- SET LRCAN=+$ORDER(^LR(LRDFN,"CH",LRIDT,1,LRCAN))
- if LRCAN<1
- QUIT
- if ($EXTRACT(^(LRCAN,0))="*")
- QUIT
- +9 ;
- +10 ; Print if cancel comment and no unverified results.
- +11 IF LRCAN<1
- QUIT
- +12 ;
- +13 if $SELECT('$DATA(SUBHEAD)
- QUIT
- +14 ;
- +15 if '$DATA(^TMP($JOB,LRDFN,"MISC",LRIDT,0))
- SET ^(0)=LRIDT_U_LRVIDT_U_LRVDT_U_LRAN_U_LRSPM_U_LREAL
- +16 SET ^TMP($JOB,LRDFN,"MISC",LRIDT,LRTNN)=""_U_LRSPM_U
- +17 ;
- +18 SET TST="See comment"
- +19 SET ^TMP("LRT",$JOB,TST)="MISCELLANEOUS TESTS"
- +20 ;
- +21 ; Grab specimen comments
- +22 DO GSC
- +23 ;
- +24 SET LRTNN=LRTNN+1
- +25 QUIT