- 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 Dec 13, 2024@02:20:46 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