LRAPQAFS ;AVAMC/REG - FROZEN SECTION/SURG PATH RPTS ;8/14/95 18:13
;;5.2;LAB SERVICE;**72,242,252**;Sep 27, 1994
S LRDICS="SP" D ^LRAP G:'$D(Y) END
W !!,"Frozen section search with optional permanent path reports.",!,"This report may take a while and should be queued to print at non-peak hours.",!,"OK to continue " S %=2 D YN^LRU G:%'=1 END
D ASK Q:%<1 W ! D B^LRU G:Y<0 END S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99
W ! S ZTRTN="QUE^LRAPQAFS" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO K ^TMP($J) S LRN="ALL",LRS(99)=1,LR("DIWF")="W",(LR,LR("A"),LR(1),LR(2),LR(3),LRQ(2))=0,LRO="" D L^LRU,S^LRU,XR^LRU,L1^LRU
S S(7)="PROCEDURE",LRSN=61.5,V=4,S(2)="ALL",LRN="FS",LRN(1)=3082,LRM(1)=4,LRN(2)=3081,LRM(2)=4,LRN(3)=3090,LRM(3)=4
S ^TMP($J,0)=S(2)_U_"FS"_U_LRO(68)_U_S(7)
F X=0:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) D LRDFN^LRAPSM
D ^LRAPSM1 G:LR("Q") OUT D EN2^LRUA,SET^LRUA S LRQ=0,LRA=1
I LRQA F A=0:0 S A=$O(^TMP($J,A)) Q:'A S X=A,%DT="" D ^%DT S LRY=$E(X,1,3) F B=0:0 S B=$O(^TMP($J,A,B)) Q:'B S ^TMP("LRAP",$J,LRY,B)=""
F LRY=0:0 S LRY=$O(^TMP("LRAP",$J,LRY)) Q:'LRY!(LR("Q")) F LRAN=0:0 S LRAN=$O(^TMP("LRAP",$J,LRY,LRAN)) Q:'LRAN!(LR("Q")) S LRDFN=$O(^LR(LRXREF,LRY,LRABV,LRAN,0)),LRI=$O(^(LRDFN,0)) D EN^LRSPRPT D:LRC L^LRAPQAMR
OUT K ^TMP("LRAP",$J) D END^LRUTL,END Q
;
ASK W !!,"Do you want corresponding permanent pathology reports",!,"to print following search " S %=2 D YN^LRU S LRQA=$S(%=1:1,1:0),LRC=0 Q:'LRQA
W !!,"Include cum path data summaries on report " S %=2 D YN^LRU S LRC=$S(%=1:1,1:0) Q
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPQAFS 1573 printed Apr 09, 2024@21:12:53 Page 2
LRAPQAFS ;AVAMC/REG - FROZEN SECTION/SURG PATH RPTS ;8/14/95 18:13
+1 ;;5.2;LAB SERVICE;**72,242,252**;Sep 27, 1994
+2 SET LRDICS="SP"
DO ^LRAP
if '$DATA(Y)
GOTO END
+3 WRITE !!,"Frozen section search with optional permanent path reports.",!,"This report may take a while and should be queued to print at non-peak hours.",!,"OK to continue "
SET %=2
DO YN^LRU
if %'=1
GOTO END
+4 DO ASK
if %<1
QUIT
WRITE !
DO B^LRU
if Y<0
GOTO END
SET LRSDT=LRSDT-.01
SET LRLDT=LRLDT+.99
+5 WRITE !
SET ZTRTN="QUE^LRAPQAFS"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
KILL ^TMP($JOB)
SET LRN="ALL"
SET LRS(99)=1
SET LR("DIWF")="W"
SET (LR,LR("A"),LR(1),LR(2),LR(3),LRQ(2))=0
SET LRO=""
DO L^LRU
DO S^LRU
DO XR^LRU
DO L1^LRU
+1 SET S(7)="PROCEDURE"
SET LRSN=61.5
SET V=4
SET S(2)="ALL"
SET LRN="FS"
SET LRN(1)=3082
SET LRM(1)=4
SET LRN(2)=3081
SET LRM(2)=4
SET LRN(3)=3090
SET LRM(3)=4
+2 SET ^TMP($JOB,0)=S(2)_U_"FS"_U_LRO(68)_U_S(7)
+3 FOR X=0:0
SET LRSDT=$ORDER(^LR(LRXR,LRSDT))
if 'LRSDT!(LRSDT>LRLDT)
QUIT
DO LRDFN^LRAPSM
+4 DO ^LRAPSM1
if LR("Q")
GOTO OUT
DO EN2^LRUA
DO SET^LRUA
SET LRQ=0
SET LRA=1
+5 IF LRQA
FOR A=0:0
SET A=$ORDER(^TMP($JOB,A))
if 'A
QUIT
SET X=A
SET %DT=""
DO ^%DT
SET LRY=$EXTRACT(X,1,3)
FOR B=0:0
SET B=$ORDER(^TMP($JOB,A,B))
if 'B
QUIT
SET ^TMP("LRAP",$JOB,LRY,B)=""
+6 FOR LRY=0:0
SET LRY=$ORDER(^TMP("LRAP",$JOB,LRY))
if 'LRY!(LR("Q"))
QUIT
FOR LRAN=0:0
SET LRAN=$ORDER(^TMP("LRAP",$JOB,LRY,LRAN))
if 'LRAN!(LR("Q"))
QUIT
SET LRDFN=$ORDER(^LR(LRXREF,LRY,LRABV,LRAN,0))
SET LRI=$ORDER(^(LRDFN,0))
DO EN^LRSPRPT
if LRC
DO L^LRAPQAMR
OUT KILL ^TMP("LRAP",$JOB)
DO END^LRUTL
DO END
QUIT
+1 ;
ASK WRITE !!,"Do you want corresponding permanent pathology reports",!,"to print following search "
SET %=2
DO YN^LRU
SET LRQA=$SELECT(%=1:1,1:0)
SET LRC=0
if 'LRQA
QUIT
+1 WRITE !!,"Include cum path data summaries on report "
SET %=2
DO YN^LRU
SET LRC=$SELECT(%=1:1,1:0)
QUIT
+2 ;
END DO V^LRU
QUIT
