LRAPQAFS.m

LRAPQAFS ;AVAMC/REG - FROZEN SECTION/SURG PATH RPTS ;8/14/95  18:13 [ 04/11/2003  11:26 AM ]

 ;;5.2T9;LR;**1002,1008,1018**;Nov 17, 2004

 ;;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

 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

Y2K S LRTMPA=$G(DT),LRTMPA=$S($E(LRTMPA,1)=2:200,1:300)  ;IHS/DIR/FJE 

 I LRQA F A=0:0 S A=$O(^TMP($J,A)) Q:'A  S LRY=A+LRTMPA F B=0:0 S B=$O(^TMP($J,A,B)) Q:'B  S ^TMP("LRAP",$J,LRY,B)="" ;IHS/DIR/FJE

 ;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)=""

 ;----- END IHS MODIFICATIONS

 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

LRAPQAFS  ;AVAMC/REG - FROZEN SECTION/SURG PATH RPTS ;8/14/95  18:13 [ 04/11/2003  11:26 AM ]

 +1       ;;5.2T9;LR;**1002,1008,1018**;Nov 17, 2004

 +2       ;;5.2;LAB SERVICE;**72,242,252**;Sep 27, 1994

 +3        SET LRDICS="SP"

           DO ^LRAP

           IF '$DATA(Y)

               GOTO END

 +4        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

 +5        DO ASK

           IF %<1

               QUIT 

           WRITE !

           DO B^LRU

           IF Y<0

               GOTO END

           SET LRSDT=LRSDT-.01

           SET LRLDT=LRLDT+.99

 +6        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       ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018

Y2K       ;IHS/DIR/FJE 

           SET LRTMPA=$GET(DT)

           SET LRTMPA=$SELECT($EXTRACT(LRTMPA,1)=2:200,1:300)

 +1       ;IHS/DIR/FJE

           IF LRQA

               FOR A=0:0

                   SET A=$ORDER(^TMP($JOB,A))

                   IF 'A

                       QUIT 

                   SET LRY=A+LRTMPA

                   FOR B=0:0

                       SET B=$ORDER(^TMP($JOB,A,B))

                       IF 'B

                           QUIT 

                       SET ^TMP("LRAP",$JOB,LRY,B)=""

 +2       ;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)=""

 +3       ;----- END IHS MODIFICATIONS

 +4        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