LRSPT ;AVAMC/REG/WTY - AP PRELIMINARY REPORTS ;10/16/01
;;5.2;LAB SERVICE;**1,72,248,259,373**;Sep 27, 1994;Build 1
;
;Reference to ^%DT supported by IA #10003
;Reference to ^DPT supported by IA #918
;Reference to ^DIWP suppported by IA #10011
;Reference to ^DIWW suppported by IA #10029
;Reference to EN^DDIOL supported by IA #10142
;
S X="T",%DT="" D ^%DT,D^LRU S LRTOD=Y D EN2^LRUA
W !!,"Preliminary reports for ",LRO(68)
G END:LRAPX=2,SGL:LRAPX=3,CH:LRAPX=4
GETP D EN1^LRUPS Q:LRAN=-1
G:$D(^LRO(69.2,LRAA,1,LRAN,0)) GETP
L +^LRO(69.2,LRAA,1):5 I '$T D G GETP
.S MSG(1)="The preliminary reports queue is in use by another person. "
.S MSG(1,"F")="!!"
.S MSG(2)="You will need to add this accession to the queue later."
.D EN^DDIOL(.MSG) K MSG
S ^LRO(69.2,LRAA,1,LRAN,0)=LRDFN_"^"_LRI
S X=^LRO(69.2,LRAA,1,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
L -^LRO(69.2,LRAA,1)
G GETP
CH S LRAPX(1)=1 D EN^LRSPRPT2 Q:%<1
W !!,"Save preliminary reports for reprinting "
S %=2 D YN^LRU S:%=1 LRSAV=1
;Variable LR("DVD") is used to divide reports displayed in the browser
K LR("DVD")
S $P(LR("DVD"),"|",IOM)=""
DEV ;
W !
S %ZIS="Q" D ^%ZIS
I POP W ! Q
I $D(IO("Q")) D Q
.S ZTDESC="ANAT PATH PRELIM REPORT"
.S ZTSAVE("LR*")="",ZTRTN="QUE^LRSPT"
.D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued, #",ZTSK W !
.K ZTSK,IO("Q") D HOME^%ZIS
QUE ;
U IO
;LRSF515=1 means this is generating and SF515.
S:'$D(LRSF515) LRSF515=0
D L^LRU,L1^LRU,S^LRU,SET^LRUA
S LR("SPSM")=1 ;Set flag to suppress printing of SNOMED codes
S LRS(5)=1,LRQ(2)=1,LRA=$S($D(^LRO(69.2,LRAA,0)):$P(^(0),U,9),1:1)
S:LRA="" LRA=1
S LR("DIWF")=$S($P(^LRO(69.2,LRAA,0),"^",6)="D":"D",1:"")_"W"
I $D(LRAP) S LRDFN=$P(LRAP,"^"),LRI=$P(LRAP,"^",2) D D G K
S LRAN=0 F S LRAN=$O(^LRO(69.2,LRAA,1,LRAN)) Q:'LRAN!(LR("Q")) D
.S X=^LRO(69.2,LRAA,1,LRAN,0),LRDFN=+X,LRI=$P(X,"^",2) D D
.W:IOST["BROWSER" !!,LR("DVD")
K K:'$D(LRSAV) ^LRO(69.2,LRAA,1) K P,S,LRAN
S ^LRO(69.2,LRAA,1,0)="^69.21A^^"
I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT
K LRSAV
W:IOST?1"P-".E @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
K %,DIR,DTOUT,DUOUT,DIRUT,X,Y
Q
D K ^UTILITY($J) I '$D(^LR(LRDFN,0)) K ^LRO(69.2,LRAA,1,LRAN) Q
N LRPRE S LRPRE=1 ;Notifies EN^LRSPRPT that this is a prelim report
D EN^LRSPRPT Q:LR("Q")
I $P($G(^LR(LRDFN,0)),"^",2)=2 D Q:LR("Q")
.D ^LRAPPOW
G:'$D(^LR(LRDFN,"SP",0))&('$D(^LR(LRDFN,"CY",0)))&('$D(^LR(LRDFN,"EM",0))) AU
D ^LRAPT1 Q:LR("Q")
AU I $D(^LR(LRDFN,"AU")),$L($P(^LR(LRDFN,"AU"),"^")) D ^LRAPT2 Q:LR("Q")
K ^UTILITY($J) S DIWR=IOM-5,DIWF="W",LR("A")=0
W ! F LRZ=0:1 S LR("A")=$O(^LRO(69.2,LRAA,10,LR("A"))) Q:'LR("A") D
.D:$Y>(IOSL-13) F^LRAPF,H S X=^LRO(69.2,LRAA,10,LR("A"),0) D ^DIWP
D:LRZ ^DIWW
S LRO=1 D F^LRAPF
Q
H ;from LRAPPF1
D F^LRU W !,"ANATOMIC PATHOLOGY",!,LR("%") Q
END W $C(7),!!,"OK TO DELETE THE ",LRO(68)," PRELIMINARY REPORT LIST" S %=2 D YN^LRU I %=1 K ^LRO(69.2,LRAA,1) S ^LRO(69.2,LRAA,1,0)="^69.21A^0^0" W $C(7),!,"LIST DELETED !" Q
W !!,"FINE, LET'S FORGET IT",! Q
;
SGL D EN1^LRUPS Q:LRAN=-1 S LRAP=LRDFN_"^"_LRI,LRSAV=1 D EN2^LRUA G DEV
CONT ;
K DIR S DIR(0)="E"
D ^DIR W !
S:$D(DTOUT)!(X[U) LR("Q")=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSPT 3242 printed Nov 22, 2024@17:30:50 Page 2
LRSPT ;AVAMC/REG/WTY - AP PRELIMINARY REPORTS ;10/16/01
+1 ;;5.2;LAB SERVICE;**1,72,248,259,373**;Sep 27, 1994;Build 1
+2 ;
+3 ;Reference to ^%DT supported by IA #10003
+4 ;Reference to ^DPT supported by IA #918
+5 ;Reference to ^DIWP suppported by IA #10011
+6 ;Reference to ^DIWW suppported by IA #10029
+7 ;Reference to EN^DDIOL supported by IA #10142
+8 ;
+9 SET X="T"
SET %DT=""
DO ^%DT
DO D^LRU
SET LRTOD=Y
DO EN2^LRUA
+10 WRITE !!,"Preliminary reports for ",LRO(68)
+11 if LRAPX=2
GOTO END
if LRAPX=3
GOTO SGL
if LRAPX=4
GOTO CH
GETP DO EN1^LRUPS
if LRAN=-1
QUIT
+1 if $DATA(^LRO(69.2,LRAA,1,LRAN,0))
GOTO GETP
+2 LOCK +^LRO(69.2,LRAA,1):5
IF '$TEST
Begin DoDot:1
+3 SET MSG(1)="The preliminary reports queue is in use by another person. "
+4 SET MSG(1,"F")="!!"
+5 SET MSG(2)="You will need to add this accession to the queue later."
+6 DO EN^DDIOL(.MSG)
KILL MSG
End DoDot:1
GOTO GETP
+7 SET ^LRO(69.2,LRAA,1,LRAN,0)=LRDFN_"^"_LRI
+8 SET X=^LRO(69.2,LRAA,1,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRAN_"^"_($PIECE(X,"^",4)+1)
+9 LOCK -^LRO(69.2,LRAA,1)
+10 GOTO GETP
CH SET LRAPX(1)=1
DO EN^LRSPRPT2
if %<1
QUIT
+1 WRITE !!,"Save preliminary reports for reprinting "
+2 SET %=2
DO YN^LRU
if %=1
SET LRSAV=1
+3 ;Variable LR("DVD") is used to divide reports displayed in the browser
+4 KILL LR("DVD")
+5 SET $PIECE(LR("DVD"),"|",IOM)=""
DEV ;
+1 WRITE !
+2 SET %ZIS="Q"
DO ^%ZIS
+3 IF POP
WRITE !
QUIT
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTDESC="ANAT PATH PRELIM REPORT"
+6 SET ZTSAVE("LR*")=""
SET ZTRTN="QUE^LRSPT"
+7 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Request Queued, #",ZTSK
WRITE !
+8 KILL ZTSK,IO("Q")
DO HOME^%ZIS
End DoDot:1
QUIT
QUE ;
+1 USE IO
+2 ;LRSF515=1 means this is generating and SF515.
+3 if '$DATA(LRSF515)
SET LRSF515=0
+4 DO L^LRU
DO L1^LRU
DO S^LRU
DO SET^LRUA
+5 ;Set flag to suppress printing of SNOMED codes
SET LR("SPSM")=1
+6 SET LRS(5)=1
SET LRQ(2)=1
SET LRA=$SELECT($DATA(^LRO(69.2,LRAA,0)):$PIECE(^(0),U,9),1:1)
+7 if LRA=""
SET LRA=1
+8 SET LR("DIWF")=$SELECT($PIECE(^LRO(69.2,LRAA,0),"^",6)="D":"D",1:"")_"W"
+9 IF $DATA(LRAP)
SET LRDFN=$PIECE(LRAP,"^")
SET LRI=$PIECE(LRAP,"^",2)
DO D
GOTO K
+10 SET LRAN=0
FOR
SET LRAN=$ORDER(^LRO(69.2,LRAA,1,LRAN))
if 'LRAN!(LR("Q"))
QUIT
Begin DoDot:1
+11 SET X=^LRO(69.2,LRAA,1,LRAN,0)
SET LRDFN=+X
SET LRI=$PIECE(X,"^",2)
DO D
+12 if IOST["BROWSER"
WRITE !!,LR("DVD")
End DoDot:1
K if '$DATA(LRSAV)
KILL ^LRO(69.2,LRAA,1)
KILL P,S,LRAN
+1 SET ^LRO(69.2,LRAA,1,0)="^69.21A^^"
+2 IF 'LR("Q")
IF $DATA(LR("F"))
IF IOST?1"C".E
DO CONT
+3 KILL LRSAV
+4 if IOST?1"P-".E
WRITE @IOF
DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 KILL %,DIR,DTOUT,DUOUT,DIRUT,X,Y
+6 QUIT
D KILL ^UTILITY($JOB)
IF '$DATA(^LR(LRDFN,0))
KILL ^LRO(69.2,LRAA,1,LRAN)
QUIT
+1 ;Notifies EN^LRSPRPT that this is a prelim report
NEW LRPRE
SET LRPRE=1
+2 DO EN^LRSPRPT
if LR("Q")
QUIT
+3 IF $PIECE($GET(^LR(LRDFN,0)),"^",2)=2
Begin DoDot:1
+4 DO ^LRAPPOW
End DoDot:1
if LR("Q")
QUIT
+5 if '$DATA(^LR(LRDFN,"SP",0))&('$DATA(^LR(LRDFN,"CY",0)))&('$DATA(^LR(LRDFN,"EM",0)))
GOTO AU
+6 DO ^LRAPT1
if LR("Q")
QUIT
AU IF $DATA(^LR(LRDFN,"AU"))
IF $LENGTH($PIECE(^LR(LRDFN,"AU"),"^"))
DO ^LRAPT2
if LR("Q")
QUIT
+1 KILL ^UTILITY($JOB)
SET DIWR=IOM-5
SET DIWF="W"
SET LR("A")=0
+2 WRITE !
FOR LRZ=0:1
SET LR("A")=$ORDER(^LRO(69.2,LRAA,10,LR("A")))
if 'LR("A")
QUIT
Begin DoDot:1
+3 if $Y>(IOSL-13)
DO F^LRAPF
DO H
SET X=^LRO(69.2,LRAA,10,LR("A"),0)
DO ^DIWP
End DoDot:1
+4 if LRZ
DO ^DIWW
+5 SET LRO=1
DO F^LRAPF
+6 QUIT
H ;from LRAPPF1
+1 DO F^LRU
WRITE !,"ANATOMIC PATHOLOGY",!,LR("%")
QUIT
END WRITE $CHAR(7),!!,"OK TO DELETE THE ",LRO(68)," PRELIMINARY REPORT LIST"
SET %=2
DO YN^LRU
IF %=1
KILL ^LRO(69.2,LRAA,1)
SET ^LRO(69.2,LRAA,1,0)="^69.21A^0^0"
WRITE $CHAR(7),!,"LIST DELETED !"
QUIT
+1 WRITE !!,"FINE, LET'S FORGET IT",!
QUIT
+2 ;
SGL DO EN1^LRUPS
if LRAN=-1
QUIT
SET LRAP=LRDFN_"^"_LRI
SET LRSAV=1
DO EN2^LRUA
GOTO DEV
CONT ;
+1 KILL DIR
SET DIR(0)="E"
+2 DO ^DIR
WRITE !
+3 if $DATA(DTOUT)!(X[U)
SET LR("Q")=1
+4 QUIT
