LR7OSAP1 ;slc/dcm/wty/kll - Silent AP rpt cont. ;3/28/2002
;;5.2;LAB SERVICE;**121,227,230,259,317,315,464**;Sep 27, 1994;Build 12
Q:'$D(^XUSEC("LRLAB",DUZ))
D LN
S $P(LR("%"),"-",GIOM)="",^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,LR("%"))
D LN
S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"SNOMED/ICD codes:")
S C=0
F S C=$O(^LR(LRDFN,LRSS,LRI,2,C)) Q:'C S T=+^(C,0),T=^LAB(61,T,0) D
. D LN
. S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"T-"_$P(T,"^",2)_": "),X=$P(T,"^")
. D:LR(69.2,.05) C^LRUA
. S ^(0)=^TMP("LRC",$J,GCNT,0)_X
. D M
D LINE^LR7OSUM4
N LRX
S C=0
F S C=$O(^LR(LRDFN,LRSS,LRI,3,C)) Q:'C S LRX=+^(C,0) D
. S LRX=$$ICDDX^ICDCODE(LRX,,,1)
. I +LRX=-1 Q
. D LN
. S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"ICD code: "_$P(LRX,"^",2))
. S X=$P(LRX,"^",4)
. D:LR(69.2,.05) C^LRUA
. S ^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(20,CCNT,X)
Q
M ;
S B=0
F S B=$O(^LR(LRDFN,LRSS,LRI,2,C,2,B)) Q:'B S M=+^(B,0),M=$G(^LAB(61.1,M,0)) I $L(M) D
. D LN
. S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(5,CCNT,"M-"_$P(M,"^",2)_": "),X=$P(M,"^")
. D:LR(69.2,.05) C^LRUA
. S ^(0)=^TMP("LRC",$J,GCNT,0)_X
. D EX
F B=1.4,3.3,4.5 S F=0 F S F=$O(^LR(LRDFN,LRSS,LRI,2,C,$P(B,"."),F)) Q:'F D A
Q
A ;
S M=+^LR(LRDFN,LRSS,LRI,2,C,$P(B,"."),F,0),E="61."_$P(B,".",2),M=^LAB(E,M,0)
D LN
S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(5,CCNT,$S(B=1.4:"D-",B=3.3:"F-",B=4.5:"P-",1:"")_$P(M,"^",2)),X=$P(M,"^")
D:LR(69.2,.05) C^LRUA
S ^(0)=^TMP("LRC",$J,GCNT,0)_": "_X
Q
EX ;
S G=0
F S G=$O(^LR(LRDFN,LRSS,LRI,2,C,2,B,1,G)) Q:'G S E=+^(G,0),E=$G(^LAB(61.2,E,0)) I $L(E) D
. D LN
. S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(10,CCNT,"E-"_$P(E,"^",2)_": "),X=$P(E,"^")
. D:LR(69.2,.05) C^LRUA
. S ^(0)=^TMP("LRC",$J,GCNT,0)_X
Q
LN ;Increment the counter
S GCNT=GCNT+1,CCNT=1
Q
MOD ;Modified report stuff
N A,B
D LN
S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(28,CCNT,"*+* MODIFIED REPORT *+*")
D LN
S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"(Last modified: ")
S B=0
F A=0:0 S A=$O(^LR(LRDFN,LRSS,LRI,LR(0),A)) Q:'A S B=A
Q:'$D(^LR(LRDFN,LRSS,LRI,LR(0),B,0)) S A=^(0),Y=+A,A=$P(A,"^",2),A=$P($G(^VA(200,A,0),A),"^")
D D^LRU
S ^(0)=^TMP("LRC",$J,GCNT,0)_Y_" typed by "_A_")"
D:$D(LRQ(9)) M1
Q
MODSR ;Modified Supplementary Report Audit Info
N LRTEXT,LRSP1,LRSP2,LRFILE,LRIENS,LRR1,LRR2
S LRFILE=$S(LRSS="CY":63.9072,LRSS="SP":63.8172,LRSS="EM":63.2072,1:"")
Q:LRFILE=""
D LN
S LRTEXT="SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED"
S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(14,CCNT,"*+* "_LRTEXT_" *+*")
D LN
S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"(Added/Last modified: ")
S LRIENS=C_","_LRI_","_LRDFN_","
S LRSP1=0
F S LRSP1=$O(^LR(LRDFN,LRSS,LRI,1.2,C,2,LRSP1)) Q:'LRSP1 D
.S LRSP2=LRSP1
Q:'$D(^LR(LRDFN,LRSS,LRI,1.2,C,2,LRSP2,0))
S LRS2=^(0),Y=+LRS2,LRS2A=$P(LRS2,"^",2),LRSGN=" typed by "
;If supp rpt is released, display 'signed by' instead of 'typed by'
I $P(LRS2,"^",3) S Y=$P(LRS2,"^",4),LRS2A=$P(LRS2,"^",3),LRSGN=" signed by "
D D^LRU
S LRS2A=$S($D(^VA(200,LRS2A,0)):$P(^(0),"^"),1:LRS2A)
S LRR1=Y,LRR2=LRS2A
S ^(0)=^TMP("LRC",$J,GCNT,0)_LRR1_LRSGN_LRR2_")"
;If RELEASED SUPP REPORT MODIFIED set to 1, display "NOT VERIFIED"
I $P(^LR(LRDFN,LRSS,LRI,1.2,C,0),"^",3)=1 D
.D LN
.S LRTEXT="NOT VERIFIED"
.S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(25,CCNT,"**-* "_LRTEXT_" *-**")
Q
M1 ;
S A=0
F S A=$O(^LR(LRDFN,LRSS,LRI,LR(0),A)) Q:'A S LRT=^(A,0),Y=+LRT,X=$P(LRT,"^",2),X=$P($G(^VA(200,X,0),X),"^") D
. D D^LRU,LN
. S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"Date modified:"_Y_" typed by "_X)
. D F
S ^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(13,CCNT,"==========Text below appears on final report==========")
Q
;
F ;
S B=0
F S B=$O(^LR(LRDFN,LRSS,LRI,LR(0),A,1,B)) Q:'B S LRT=^(B,0),X=LRT D LN S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,X)
Q
WRAP(ROOT,FMT) ;Wrap text
I '$L($G(ROOT)) Q ""
S:'$G(FMT) FMT=79
N X,LRI,LRTX,LRINDX
S LRINDX=0,LRI=0
F S LRI=$O(@ROOT@(LRI)) Q:LRI'>0 D
. S X=$S($L($G(@ROOT@(LRI))):@ROOT@(LRI),$L($G(@ROOT@(LRI,0))):@ROOT@(LRI,0),1:""),LRINDX=LRINDX+1
. S LRTX(LRI)=X
S LRI=0
F S LRI=$O(LRTX(LRI)) Q:'LRI D LN^LR7OSAP S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,LRTX(LRI))
Q
FMT(LENGTH,INDEX,TEXT) ;Format text
N X,Y,J
S Y=1
S:'$D(LRTX(INDEX)) LRTX(INDEX)=""
S X=$L(TEXT)+$L(LRTX(INDEX))+1
I X<255 S TEXT=$S($L(LRTX(INDEX)):LRTX(INDEX)_" "_TEXT,1:TEXT)
I X'<255 S INDEX=INDEX+1,LRTX(INDEX)=""
S LRTX(INDEX)=""
F J=1:1 S X=$P(TEXT," ",J) Q:J>$L(TEXT," ") D
. Q:'$L(X)
. I ($L(X)+$L(LRTX(INDEX)))>LENGTH S Y=1,INDEX=INDEX+1,LRTX(INDEX)=""
. S LRTX(INDEX)=$S(Y:X,1:LRTX(INDEX)_" "_X),Y=0
S LRTX(INDEX)=$$STRIP(LRTX(INDEX))
Q INDEX
STRIP(TEXT) ; Strips white space from text
N LRI,LRX
S LRX="" F LRI=1:1:$L(TEXT," ") S:$A($P(TEXT," ",LRI))>0 LRX=LRX_$S(LRI=1:"",1:" ")_$P(TEXT," ",LRI)
S TEXT=LRX
Q TEXT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OSAP1 4910 printed Jan 18, 2025@03:06:08 Page 2
LR7OSAP1 ;slc/dcm/wty/kll - Silent AP rpt cont. ;3/28/2002
+1 ;;5.2;LAB SERVICE;**121,227,230,259,317,315,464**;Sep 27, 1994;Build 12
+2 if '$DATA(^XUSEC("LRLAB",DUZ))
QUIT
+3 DO LN
+4 SET $PIECE(LR("%"),"-",GIOM)=""
SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,LR("%"))
+5 DO LN
+6 SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,"SNOMED/ICD codes:")
+7 SET C=0
+8 FOR
SET C=$ORDER(^LR(LRDFN,LRSS,LRI,2,C))
if 'C
QUIT
SET T=+^(C,0)
SET T=^LAB(61,T,0)
Begin DoDot:1
+9 DO LN
+10 SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,"T-"_$PIECE(T,"^",2)_": ")
SET X=$PIECE(T,"^")
+11 if LR(69.2,.05)
DO C^LRUA
+12 SET ^(0)=^TMP("LRC",$JOB,GCNT,0)_X
+13 DO M
End DoDot:1
+14 DO LINE^LR7OSUM4
+15 NEW LRX
+16 SET C=0
+17 FOR
SET C=$ORDER(^LR(LRDFN,LRSS,LRI,3,C))
if 'C
QUIT
SET LRX=+^(C,0)
Begin DoDot:1
+18 SET LRX=$$ICDDX^ICDCODE(LRX,,,1)
+19 IF +LRX=-1
QUIT
+20 DO LN
+21 SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,"ICD code: "_$PIECE(LRX,"^",2))
+22 SET X=$PIECE(LRX,"^",4)
+23 if LR(69.2,.05)
DO C^LRUA
+24 SET ^(0)=^TMP("LRC",$JOB,GCNT,0)_$$S^LR7OS(20,CCNT,X)
End DoDot:1
+25 QUIT
M ;
+1 SET B=0
+2 FOR
SET B=$ORDER(^LR(LRDFN,LRSS,LRI,2,C,2,B))
if 'B
QUIT
SET M=+^(B,0)
SET M=$GET(^LAB(61.1,M,0))
IF $LENGTH(M)
Begin DoDot:1
+3 DO LN
+4 SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(5,CCNT,"M-"_$PIECE(M,"^",2)_": ")
SET X=$PIECE(M,"^")
+5 if LR(69.2,.05)
DO C^LRUA
+6 SET ^(0)=^TMP("LRC",$JOB,GCNT,0)_X
+7 DO EX
End DoDot:1
+8 FOR B=1.4,3.3,4.5
SET F=0
FOR
SET F=$ORDER(^LR(LRDFN,LRSS,LRI,2,C,$PIECE(B,"."),F))
if 'F
QUIT
DO A
+9 QUIT
A ;
+1 SET M=+^LR(LRDFN,LRSS,LRI,2,C,$PIECE(B,"."),F,0)
SET E="61."_$PIECE(B,".",2)
SET M=^LAB(E,M,0)
+2 DO LN
+3 SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(5,CCNT,$SELECT(B=1.4:"D-",B=3.3:"F-",B=4.5:"P-",1:"")_$PIECE(M,"^",2))
SET X=$PIECE(M,"^")
+4 if LR(69.2,.05)
DO C^LRUA
+5 SET ^(0)=^TMP("LRC",$JOB,GCNT,0)_": "_X
+6 QUIT
EX ;
+1 SET G=0
+2 FOR
SET G=$ORDER(^LR(LRDFN,LRSS,LRI,2,C,2,B,1,G))
if 'G
QUIT
SET E=+^(G,0)
SET E=$GET(^LAB(61.2,E,0))
IF $LENGTH(E)
Begin DoDot:1
+3 DO LN
+4 SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(10,CCNT,"E-"_$PIECE(E,"^",2)_": ")
SET X=$PIECE(E,"^")
+5 if LR(69.2,.05)
DO C^LRUA
+6 SET ^(0)=^TMP("LRC",$JOB,GCNT,0)_X
End DoDot:1
+7 QUIT
LN ;Increment the counter
+1 SET GCNT=GCNT+1
SET CCNT=1
+2 QUIT
MOD ;Modified report stuff
+1 NEW A,B
+2 DO LN
+3 SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(28,CCNT,"*+* MODIFIED REPORT *+*")
+4 DO LN
+5 SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,"(Last modified: ")
+6 SET B=0
+7 FOR A=0:0
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,LR(0),A))
if 'A
QUIT
SET B=A
+8 if '$DATA(^LR(LRDFN,LRSS,LRI,LR(0),B,0))
QUIT
SET A=^(0)
SET Y=+A
SET A=$PIECE(A,"^",2)
SET A=$PIECE($GET(^VA(200,A,0),A),"^")
+9 DO D^LRU
+10 SET ^(0)=^TMP("LRC",$JOB,GCNT,0)_Y_" typed by "_A_")"
+11 if $DATA(LRQ(9))
DO M1
+12 QUIT
MODSR ;Modified Supplementary Report Audit Info
+1 NEW LRTEXT,LRSP1,LRSP2,LRFILE,LRIENS,LRR1,LRR2
+2 SET LRFILE=$SELECT(LRSS="CY":63.9072,LRSS="SP":63.8172,LRSS="EM":63.2072,1:"")
+3 if LRFILE=""
QUIT
+4 DO LN
+5 SET LRTEXT="SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED"
+6 SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(14,CCNT,"*+* "_LRTEXT_" *+*")
+7 DO LN
+8 SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,"(Added/Last modified: ")
+9 SET LRIENS=C_","_LRI_","_LRDFN_","
+10 SET LRSP1=0
+11 FOR
SET LRSP1=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,C,2,LRSP1))
if 'LRSP1
QUIT
Begin DoDot:1
+12 SET LRSP2=LRSP1
End DoDot:1
+13 if '$DATA(^LR(LRDFN,LRSS,LRI,1.2,C,2,LRSP2,0))
QUIT
+14 SET LRS2=^(0)
SET Y=+LRS2
SET LRS2A=$PIECE(LRS2,"^",2)
SET LRSGN=" typed by "
+15 ;If supp rpt is released, display 'signed by' instead of 'typed by'
+16 IF $PIECE(LRS2,"^",3)
SET Y=$PIECE(LRS2,"^",4)
SET LRS2A=$PIECE(LRS2,"^",3)
SET LRSGN=" signed by "
+17 DO D^LRU
+18 SET LRS2A=$SELECT($DATA(^VA(200,LRS2A,0)):$PIECE(^(0),"^"),1:LRS2A)
+19 SET LRR1=Y
SET LRR2=LRS2A
+20 SET ^(0)=^TMP("LRC",$JOB,GCNT,0)_LRR1_LRSGN_LRR2_")"
+21 ;If RELEASED SUPP REPORT MODIFIED set to 1, display "NOT VERIFIED"
+22 IF $PIECE(^LR(LRDFN,LRSS,LRI,1.2,C,0),"^",3)=1
Begin DoDot:1
+23 DO LN
+24 SET LRTEXT="NOT VERIFIED"
+25 SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(25,CCNT,"**-* "_LRTEXT_" *-**")
End DoDot:1
+26 QUIT
M1 ;
+1 SET A=0
+2 FOR
SET A=$ORDER(^LR(LRDFN,LRSS,LRI,LR(0),A))
if 'A
QUIT
SET LRT=^(A,0)
SET Y=+LRT
SET X=$PIECE(LRT,"^",2)
SET X=$PIECE($GET(^VA(200,X,0),X),"^")
Begin DoDot:1
+3 DO D^LRU
DO LN
+4 SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,"Date modified:"_Y_" typed by "_X)
+5 DO F
End DoDot:1
+6 SET ^(0)=^TMP("LRC",$JOB,GCNT,0)_$$S^LR7OS(13,CCNT,"==========Text below appears on final report==========")
+7 QUIT
+8 ;
F ;
+1 SET B=0
+2 FOR
SET B=$ORDER(^LR(LRDFN,LRSS,LRI,LR(0),A,1,B))
if 'B
QUIT
SET LRT=^(B,0)
SET X=LRT
DO LN
SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,X)
+3 QUIT
WRAP(ROOT,FMT) ;Wrap text
+1 IF '$LENGTH($GET(ROOT))
QUIT ""
+2 if '$GET(FMT)
SET FMT=79
+3 NEW X,LRI,LRTX,LRINDX
+4 SET LRINDX=0
SET LRI=0
+5 FOR
SET LRI=$ORDER(@ROOT@(LRI))
if LRI'>0
QUIT
Begin DoDot:1
+6 SET X=$SELECT($LENGTH($GET(@ROOT@(LRI))):@ROOT@(LRI),$LENGTH($GET(@ROOT@(LRI,0))):@ROOT@(LRI,0),1:"")
SET LRINDX=LRINDX+1
+7 SET LRTX(LRI)=X
End DoDot:1
+8 SET LRI=0
+9 FOR
SET LRI=$ORDER(LRTX(LRI))
if 'LRI
QUIT
DO LN^LR7OSAP
SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,LRTX(LRI))
+10 QUIT
FMT(LENGTH,INDEX,TEXT) ;Format text
+1 NEW X,Y,J
+2 SET Y=1
+3 if '$DATA(LRTX(INDEX))
SET LRTX(INDEX)=""
+4 SET X=$LENGTH(TEXT)+$LENGTH(LRTX(INDEX))+1
+5 IF X<255
SET TEXT=$SELECT($LENGTH(LRTX(INDEX)):LRTX(INDEX)_" "_TEXT,1:TEXT)
+6 IF X'<255
SET INDEX=INDEX+1
SET LRTX(INDEX)=""
+7 SET LRTX(INDEX)=""
+8 FOR J=1:1
SET X=$PIECE(TEXT," ",J)
if J>$LENGTH(TEXT," ")
QUIT
Begin DoDot:1
+9 if '$LENGTH(X)
QUIT
+10 IF ($LENGTH(X)+$LENGTH(LRTX(INDEX)))>LENGTH
SET Y=1
SET INDEX=INDEX+1
SET LRTX(INDEX)=""
+11 SET LRTX(INDEX)=$SELECT(Y:X,1:LRTX(INDEX)_" "_X)
SET Y=0
End DoDot:1
+12 SET LRTX(INDEX)=$$STRIP(LRTX(INDEX))
+13 QUIT INDEX
STRIP(TEXT) ; Strips white space from text
+1 NEW LRI,LRX
+2 SET LRX=""
FOR LRI=1:1:$LENGTH(TEXT," ")
if $ASCII($PIECE(TEXT," ",LRI))>0
SET LRX=LRX_$SELECT(LRI=1:"",1:" ")_$PIECE(TEXT," ",LRI)
+3 SET TEXT=LRX
+4 QUIT TEXT
