- LRSPRPT ;DALOI/STAFF - CY/EM/SP PATIENT RPT ; 30 Aug 2016 5:20 PM
- ;;5.2;LAB SERVICE;**1,72,248,259,317,350,416,464**;Sep 27, 1994;Build 12
- ;
- W !!?20,LRO(68)," FINAL PATIENT REPORTS"
- K LRSAV,LRAP,LRS(99)
- D EN2^LRUA
- G END^LRSPRPT1:LRAPX=2,SGL:LRAPX=3,CH:LRAPX=4
- GETP ;
- D EN1^LRUPS Q:LRAN=-1
- G:$D(^LRO(69.2,LRAA,2,LRAN,0)) GETP
- D LOCK^DILF("^LRO(69.2,LRAA,2)")
- I '$T D G GETP
- . N MSG
- . S MSG(1)="The final reports queue is in use by another person.",MSG(1,"F")="!!"
- . S MSG(2)="You will need to add this accession to the queue later."
- . D EN^DDIOL(.MSG)
- S ^LRO(69.2,LRAA,2,LRAN,0)=LRDFN_"^"_LRI
- S X=^LRO(69.2,LRAA,2,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
- L -^LRO(69.2,LRAA,2)
- G GETP
- ;
- ;
- CH ;
- S LRAPX(1)=2 D EN^LRSPRPT2 Q:$G(%)<1
- W !!,"Save final report list 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 ; from LRAPMOD
- W !
- S %ZIS="Q" D ^%ZIS
- I POP W ! D END Q
- I $D(IO("Q")) D Q
- . N ZTDESC,ZTRTN,ZTSAVE,ZTSK
- . S ZTDESC="ANAT PATH FINAL REPORT"
- . S ZTSAVE("LR*")="",ZTRTN="QUE^LRSPRPT"
- . D ^%ZTLOAD,HOME^%ZIS
- . D EN^DDIOL("Request "_$S($G(ZTSK):"queued - Task #"_ZTSK,1:"NOT queued"),"","!")
- . D END
- ;
- QUE ;
- U IO
- N LRFFF
- ; LRSF515=1 means generating an SF515
- S:'$D(LRSF515) LRSF515=0
- S:'$D(LRFOC) LRFOC=0
- S:'$D(LRQUIT) LRQUIT=0
- S LRFFF=1 ;Flag to perform final form feed
- I LRFOC S LRFFF=0 ;If final office copy, don't perform final form feed
- S LR(.21)=+$G(^LRO(69.2,LRAA,.2)),LR("DIWF")="W"
- S LRA=$S($D(^LRO(69.2,LRAA,0)):$P(^(0),U,9),1:1) S:LRA="" LRA=1
- D L^LRU,S^LRU,L1^LRU,SET^LRUA
- ;
- PSGL ; Single Report
- I $D(LRAP) D G LST
- . S LRDFN=$P(LRAP,"^"),LRI=$P(LRAP,"^",2)
- . I +$G(LRPTR) D Q
- . . D MAIN^LRAPTIUP(LRPTR,0)
- . . S LRFFF=0 ;Don't do final form feed. It's done by LRAPTIUP.
- . . I LRQUIT S LR("Q")=1 Q
- . . K LRAP S LR("F")=1
- . . I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT
- . . Q:LR("Q")
- . . I 'LRFOC S LR("Q")=1 Q
- . . D FOC
- . . I LRQUIT S LR("Q")=1 Q
- . . I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT
- . W:IOST?1"C-".E @IOF
- . D EN
- . K LRAP
- . I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT
- . Q:LR("Q")
- . I 'LRFOC S LR("Q")=1 Q
- . W !
- . W:IOST?1"P-".E @IOF
- . D FOC
- . I LRQUIT S LR("Q")=1 Q
- . I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT
- ;
- PQUE ;Report from queue
- S LRAN=0
- F S LRAN=$O(^LRO(69.2,LRAA,2,LRAN)) Q:'LRAN!(LR("Q")) D
- . S LRQUIT=0
- . I 'LRFOC S LRFFF=1
- . K LR("F")
- . S X=^LRO(69.2,LRAA,2,LRAN,0),LRDFN=+X,LRI=$P(X,"^",2)
- . D TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS,LRI)
- . I +$G(LRPTR) D Q
- . . D MAIN^LRAPTIUP(LRPTR,0)
- . . S LRFFF=0
- . . W:IOST["BROWSER"&('LRFOC) !!,LR("DVD")
- . . K LRPTR
- . . I LRQUIT S LR("Q")=1 Q
- . . S LR("F")=1
- . . I 'LR("Q"),$D(LR("F")),IOST?1"C-".E D CONT
- . . Q:LR("Q")!('LRFOC)
- . . D FOC
- . . W:IOST["BROWSER" !!,LR("DVD")
- . . I LRQUIT S LR("Q")=1 Q
- . . I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT
- . W:IOST?1"C-".E @IOF
- . D EN
- . W:IOST?1"P-".E @IOF
- . W:IOST["BROWSER"&('LRFOC) !!,LR("DVD")
- . I 'LR("Q"),$D(LR("F")),IOST?1"C-".E D CONT
- . Q:LR("Q")
- . Q:'LRFOC
- . W !
- . D FOC
- . W:IOST["BROWSER" !!,LR("DVD")
- . I LRQUIT S LR("Q")=1 Q
- . I 'LR("Q"),$D(LR("F")),IOST?1"C".E D CONT
- S LRFFF=0
- ;
- LST ;
- K LRRMD,LRPMD,LRAP
- K:'$D(LRSAV) ^LRO(69.2,LRAA,2)
- S ^LRO(69.2,LRAA,2,0)="^69.23A^^0"
- K LRSAV,LRV,LRW,LRZ
- I IOST?1"P-".E W:LRFFF @IOF
- D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
- K %,DIR,DTOUT,DUOUT,DIRUT,X,Y
- D END
- Q
- ;
- ;
- W ;
- W !,LR("%")
- Q
- ;
- ;
- F ;
- ; N A,DIWF,DIWL,DIWR
- D E
- S A=0,DIWF=$TR(DIWF,"W","")
- F S A=$O(^LR(LRDFN,LRSS,LRI,LRV,A)) Q:'A S X=^LR(LRDFN,LRSS,LRI,LRV,A,0) D:X["|TOP|" TOP D ^DIWP
- S A=0
- F S A=$O(^UTILITY($J,"W",DIWL,A)) Q:'A D:$Y>(IOSL-11) F^LRAPF,^LRAPF Q:LR("Q") W !,^UTILITY($J,"W",DIWL,A,0)
- I $Y<(IOSL-11) W !
- K ^UTILITY($J,"W")
- Q
- ;
- ;
- E ;
- K ^UTILITY($J,"W")
- S DIWR=IOM-5,DIWL=5,DIWF=""
- ;
- ; Set gross description field to value from file #69.2
- ;I LRV=1 S DIWF=LR("DIWF")
- S DIWF=LR("DIWF")
- ;
- Q
- ;
- ;
- EN ; from LRSPT
- ; Moved to LRSPRPTA due to size limits on routine
- D EN^LRSPRPTA
- Q
- ;
- ;
- S ;
- S Y=+X,X=$P(X,U,2) D D^LRU
- W !?3,"Date: ",Y
- I $D(LR("R")),'X W " not verified" Q
- D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")
- D:$P($G(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,0)),U,4) SUPA
- D E S B=0
- F LRZ=0:1 S B=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV,1,B)) Q:'B!(LR("Q")) D
- . D:$Y>(IOSL-14) F^LRAPF,^LRAPF Q:LR("Q")
- . ;S DIWF="W" ;LR*5.2*464
- . S DIWF="WN" ;LR*5.2*464
- . S X=^LR(LRDFN,LRSS,LRI,1.2,LRV,1,B,0) D ^DIWP Q:LR("Q")
- Q:LR("Q")
- D:LRZ ^DIWW
- Q
- ;
- ;
- SGL ; Print Single Report
- N LRPTR
- S LRAPX(1)=""
- D EN1^LRUPS Q:LRAN=-1
- I '$P(^LR(LRDFN,LRSS,LRI,0),"^",11) D G SGL
- . W $C(7)," Sorry, report not verified.",!
- D TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS,LRI)
- S LRAP=LRDFN_"^"_LRI,LRSAV=1
- D EN2^LRUA
- G DEV
- ;
- ;
- A ;
- S A=0 F S A=$O(^LR(LRDFN,LRSS,LRI,LRV,A)) Q:'A!(LR("Q")) D
- . D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")
- . W !,$P(^LR(LRDFN,LRSS,LRI,LRV,A,0),"^")
- Q
- ;
- ;
- TOP ;
- S Z=$P(X,"|TOP|",1)_$P(X,"|TOP|",2) D F^LRAPF,^LRAPF S X=Z
- Q
- ;
- ;
- SUPA ; Print supplementary report audit information
- W !?14,"*+* SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED *+*"
- W !,"(Added/Last modified: "
- S (A,B)=0 F S A=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A)) Q:'A!(LR("Q")) D
- . S B=A
- Q:LR("Q")
- Q:'$D(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,B,0))
- S A=^(0),Y=+A,LRSGN=" typed by ",A=$P(A,"^",2)
- I $P(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,B,0),"^",3) D
- . S A=^(0),LRSGN=" signed by ",A2=$P(A,"^",3),Y=$P(A,"^",4)
- . S A=A2
- S A=$S($D(^VA(200,A,0)):$P(^(0),"^"),1:A)
- ; If supp rpt is released, display 'signed by' instead of 'typed by'
- D D^LRU W Y,LRSGN,A,")"
- ; If RELEASE SUPP REPORT MODIFIED set to 1, display "NOT VERIFIED"
- I $P(^LR(LRDFN,LRSS,LRI,1.2,LRV,0),"^",3) W !,?25,"**-* NOT VERIFIED *-**"
- D:$D(LRQ(9)) SUPM
- Q
- ;
- ;
- SUPM ; Print previous versions of supplementary reports
- ; This is used by menu option 'Print path modifications [LRAPMOD]'
- ;
- S A=0 F S A=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A)) Q:'A!(LR("Q")) D
- . S LRT=^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A,0)
- . D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")
- . S Y=+LRT,Y2=" modified: ",X=$P(LRT,"^",2),LRSGN=" typed by "
- . ; If supp rpt is released, display 'signed by' instead of 'typed by'
- . I $P(LRT,"^",3) S LRSGN=" signed by ",X=$P(LRT,"^",3),Y=$P(LRT,"^",4),Y2=" released: "
- . S X=$S($D(^VA(200,X,0)):$P(^(0),"^"),1:X)
- . D D^LRU W !,"Date ",Y2,Y,LRSGN,X
- . K ^UTILITY($J)
- . S DIWR=IOM-5,DIWL=5,DIWF="W"
- . S B=0
- . F LRZ=0:1 S B=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A,1,B)) Q:'B!(LR("Q")) D
- . . S LRT=^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A,1,B,0)
- . . D:$Y>(IOSL-13) F^LRAPF,^LRAPF Q:LR("Q")
- . . S X=LRT D ^DIWP
- . Q:LR("Q") D:LRZ ^DIWW
- Q:LR("Q")
- W !?13,"==========Text below appears on final report=========="
- Q
- ;
- ;
- CONT ;
- K DIR S DIR(0)="E"
- D ^DIR W !
- S:$D(DTOUT)!(X[U) LR("Q")=1
- Q
- ;
- ;
- FOC ; Print final office copy page (SNOMEDS)
- N LRADC,LRCTR
- I '$D(LRAP) D
- . D:LRSS'="AU" ^LRUA
- . I LRSS="AU" S X=^LR(LRDFN,0) D ^LRUP
- I LRSS="AU" D
- . S LRADC=$E($P(^LR(LRDFN,LRSS),"^"),1,3)_"0000"
- . S:+$G(LRDPF)=2 LRDEM("DTH")=$P(VADM(6),"^",2)
- . ; Get DATE DIED from Referral File for Referral Patients
- . S:+$G(LRDPF)'=2 LRDEM("DTH")=$$GET1^DIQ(67,DFN_",",.351)
- . S LRDEM("AUDT")=$$GET1^DIQ(63,LRDFN_",",11)
- . S LRDEM("AUTYP")=$$GET1^DIQ(63,LRDFN_",",13.7)
- . S LRDEM("PRO")=$$GET1^DIQ(63,LRDFN_",",13.5)
- I LRSS'="AU" D
- . S LRADC=$E($P(^LR(LRDFN,LRSS,LRI,0),"^",10),1,3)_"0000"
- . S LRDEM("PRO")=LRMD
- S LRDEM("PNM")=LRP,LRDEM("SSN")=SSN
- S LRDEM("SEX")=SEX,LRDEM("AGE")=AGE,LRDEM("DOB")=DOB
- D INIT^LRAPSNMD(LRDFN,LRSS,$G(LRI),LRSF,LRAA,LRAN,LRADC,.LRDEM,0)
- Q
- ;
- ;
- END ;
- D V^LRU
- K LRSF515
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSPRPT 7897 printed Jan 18, 2025@03:21:20 Page 2
- LRSPRPT ;DALOI/STAFF - CY/EM/SP PATIENT RPT ; 30 Aug 2016 5:20 PM
- +1 ;;5.2;LAB SERVICE;**1,72,248,259,317,350,416,464**;Sep 27, 1994;Build 12
- +2 ;
- +3 WRITE !!?20,LRO(68)," FINAL PATIENT REPORTS"
- +4 KILL LRSAV,LRAP,LRS(99)
- +5 DO EN2^LRUA
- +6 if LRAPX=2
- GOTO END^LRSPRPT1
- if LRAPX=3
- GOTO SGL
- if LRAPX=4
- GOTO CH
- GETP ;
- +1 DO EN1^LRUPS
- if LRAN=-1
- QUIT
- +2 if $DATA(^LRO(69.2,LRAA,2,LRAN,0))
- GOTO GETP
- +3 DO LOCK^DILF("^LRO(69.2,LRAA,2)")
- +4 IF '$TEST
- Begin DoDot:1
- +5 NEW MSG
- +6 SET MSG(1)="The final reports queue is in use by another person."
- SET MSG(1,"F")="!!"
- +7 SET MSG(2)="You will need to add this accession to the queue later."
- +8 DO EN^DDIOL(.MSG)
- End DoDot:1
- GOTO GETP
- +9 SET ^LRO(69.2,LRAA,2,LRAN,0)=LRDFN_"^"_LRI
- +10 SET X=^LRO(69.2,LRAA,2,0)
- SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRAN_"^"_($PIECE(X,"^",4)+1)
- +11 LOCK -^LRO(69.2,LRAA,2)
- +12 GOTO GETP
- +13 ;
- +14 ;
- CH ;
- +1 SET LRAPX(1)=2
- DO EN^LRSPRPT2
- if $GET(%)<1
- QUIT
- +2 WRITE !!,"Save final report list for reprinting "
- +3 SET %=2
- DO YN^LRU
- if %=1
- SET LRSAV=1
- +4 ; Variable LR("DVD") is used to divide reports displayed in the browser
- +5 KILL LR("DVD")
- +6 SET $PIECE(LR("DVD"),"|",IOM)=""
- DEV ; from LRAPMOD
- +1 WRITE !
- +2 SET %ZIS="Q"
- DO ^%ZIS
- +3 IF POP
- WRITE !
- DO END
- QUIT
- +4 IF $DATA(IO("Q"))
- Begin DoDot:1
- +5 NEW ZTDESC,ZTRTN,ZTSAVE,ZTSK
- +6 SET ZTDESC="ANAT PATH FINAL REPORT"
- +7 SET ZTSAVE("LR*")=""
- SET ZTRTN="QUE^LRSPRPT"
- +8 DO ^%ZTLOAD
- DO HOME^%ZIS
- +9 DO EN^DDIOL("Request "_$SELECT($GET(ZTSK):"queued - Task #"_ZTSK,1:"NOT queued"),"","!")
- +10 DO END
- End DoDot:1
- QUIT
- +11 ;
- QUE ;
- +1 USE IO
- +2 NEW LRFFF
- +3 ; LRSF515=1 means generating an SF515
- +4 if '$DATA(LRSF515)
- SET LRSF515=0
- +5 if '$DATA(LRFOC)
- SET LRFOC=0
- +6 if '$DATA(LRQUIT)
- SET LRQUIT=0
- +7 ;Flag to perform final form feed
- SET LRFFF=1
- +8 ;If final office copy, don't perform final form feed
- IF LRFOC
- SET LRFFF=0
- +9 SET LR(.21)=+$GET(^LRO(69.2,LRAA,.2))
- SET LR("DIWF")="W"
- +10 SET LRA=$SELECT($DATA(^LRO(69.2,LRAA,0)):$PIECE(^(0),U,9),1:1)
- if LRA=""
- SET LRA=1
- +11 DO L^LRU
- DO S^LRU
- DO L1^LRU
- DO SET^LRUA
- +12 ;
- PSGL ; Single Report
- +1 IF $DATA(LRAP)
- Begin DoDot:1
- +2 SET LRDFN=$PIECE(LRAP,"^")
- SET LRI=$PIECE(LRAP,"^",2)
- +3 IF +$GET(LRPTR)
- Begin DoDot:2
- +4 DO MAIN^LRAPTIUP(LRPTR,0)
- +5 ;Don't do final form feed. It's done by LRAPTIUP.
- SET LRFFF=0
- +6 IF LRQUIT
- SET LR("Q")=1
- QUIT
- +7 KILL LRAP
- SET LR("F")=1
- +8 IF 'LR("Q")
- IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO CONT
- +9 if LR("Q")
- QUIT
- +10 IF 'LRFOC
- SET LR("Q")=1
- QUIT
- +11 DO FOC
- +12 IF LRQUIT
- SET LR("Q")=1
- QUIT
- +13 IF 'LR("Q")
- IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO CONT
- End DoDot:2
- QUIT
- +14 if IOST?1"C-".E
- WRITE @IOF
- +15 DO EN
- +16 KILL LRAP
- +17 IF 'LR("Q")
- IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO CONT
- +18 if LR("Q")
- QUIT
- +19 IF 'LRFOC
- SET LR("Q")=1
- QUIT
- +20 WRITE !
- +21 if IOST?1"P-".E
- WRITE @IOF
- +22 DO FOC
- +23 IF LRQUIT
- SET LR("Q")=1
- QUIT
- +24 IF 'LR("Q")
- IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO CONT
- End DoDot:1
- GOTO LST
- +25 ;
- PQUE ;Report from queue
- +1 SET LRAN=0
- +2 FOR
- SET LRAN=$ORDER(^LRO(69.2,LRAA,2,LRAN))
- if 'LRAN!(LR("Q"))
- QUIT
- Begin DoDot:1
- +3 SET LRQUIT=0
- +4 IF 'LRFOC
- SET LRFFF=1
- +5 KILL LR("F")
- +6 SET X=^LRO(69.2,LRAA,2,LRAN,0)
- SET LRDFN=+X
- SET LRI=$PIECE(X,"^",2)
- +7 DO TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS,LRI)
- +8 IF +$GET(LRPTR)
- Begin DoDot:2
- +9 DO MAIN^LRAPTIUP(LRPTR,0)
- +10 SET LRFFF=0
- +11 if IOST["BROWSER"&('LRFOC)
- WRITE !!,LR("DVD")
- +12 KILL LRPTR
- +13 IF LRQUIT
- SET LR("Q")=1
- QUIT
- +14 SET LR("F")=1
- +15 IF 'LR("Q")
- IF $DATA(LR("F"))
- IF IOST?1"C-".E
- DO CONT
- +16 if LR("Q")!('LRFOC)
- QUIT
- +17 DO FOC
- +18 if IOST["BROWSER"
- WRITE !!,LR("DVD")
- +19 IF LRQUIT
- SET LR("Q")=1
- QUIT
- +20 IF 'LR("Q")
- IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO CONT
- End DoDot:2
- QUIT
- +21 if IOST?1"C-".E
- WRITE @IOF
- +22 DO EN
- +23 if IOST?1"P-".E
- WRITE @IOF
- +24 if IOST["BROWSER"&('LRFOC)
- WRITE !!,LR("DVD")
- +25 IF 'LR("Q")
- IF $DATA(LR("F"))
- IF IOST?1"C-".E
- DO CONT
- +26 if LR("Q")
- QUIT
- +27 if 'LRFOC
- QUIT
- +28 WRITE !
- +29 DO FOC
- +30 if IOST["BROWSER"
- WRITE !!,LR("DVD")
- +31 IF LRQUIT
- SET LR("Q")=1
- QUIT
- +32 IF 'LR("Q")
- IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO CONT
- End DoDot:1
- +33 SET LRFFF=0
- +34 ;
- LST ;
- +1 KILL LRRMD,LRPMD,LRAP
- +2 if '$DATA(LRSAV)
- KILL ^LRO(69.2,LRAA,2)
- +3 SET ^LRO(69.2,LRAA,2,0)="^69.23A^^0"
- +4 KILL LRSAV,LRV,LRW,LRZ
- +5 IF IOST?1"P-".E
- if LRFFF
- WRITE @IOF
- +6 DO ^%ZISC
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +7 KILL %,DIR,DTOUT,DUOUT,DIRUT,X,Y
- +8 DO END
- +9 QUIT
- +10 ;
- +11 ;
- W ;
- +1 WRITE !,LR("%")
- +2 QUIT
- +3 ;
- +4 ;
- F ;
- +1 ; N A,DIWF,DIWL,DIWR
- +2 DO E
- +3 SET A=0
- SET DIWF=$TRANSLATE(DIWF,"W","")
- +4 FOR
- SET A=$ORDER(^LR(LRDFN,LRSS,LRI,LRV,A))
- if 'A
- QUIT
- SET X=^LR(LRDFN,LRSS,LRI,LRV,A,0)
- if X["|TOP|"
- DO TOP
- DO ^DIWP
- +5 SET A=0
- +6 FOR
- SET A=$ORDER(^UTILITY($JOB,"W",DIWL,A))
- if 'A
- QUIT
- if $Y>(IOSL-11)
- DO F^LRAPF
- DO ^LRAPF
- if LR("Q")
- QUIT
- WRITE !,^UTILITY($JOB,"W",DIWL,A,0)
- +7 IF $Y<(IOSL-11)
- WRITE !
- +8 KILL ^UTILITY($JOB,"W")
- +9 QUIT
- +10 ;
- +11 ;
- E ;
- +1 KILL ^UTILITY($JOB,"W")
- +2 SET DIWR=IOM-5
- SET DIWL=5
- SET DIWF=""
- +3 ;
- +4 ; Set gross description field to value from file #69.2
- +5 ;I LRV=1 S DIWF=LR("DIWF")
- +6 SET DIWF=LR("DIWF")
- +7 ;
- +8 QUIT
- +9 ;
- +10 ;
- EN ; from LRSPT
- +1 ; Moved to LRSPRPTA due to size limits on routine
- +2 DO EN^LRSPRPTA
- +3 QUIT
- +4 ;
- +5 ;
- S ;
- +1 SET Y=+X
- SET X=$PIECE(X,U,2)
- DO D^LRU
- +2 WRITE !?3,"Date: ",Y
- +3 IF $DATA(LR("R"))
- IF 'X
- WRITE " not verified"
- QUIT
- +4 if $Y>(IOSL-13)
- DO F^LRAPF
- DO ^LRAPF
- if LR("Q")
- QUIT
- +5 if $PIECE($GET(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,0)),U,4)
- DO SUPA
- +6 DO E
- SET B=0
- +7 FOR LRZ=0:1
- SET B=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,LRV,1,B))
- if 'B!(LR("Q"))
- QUIT
- Begin DoDot:1
- +8 if $Y>(IOSL-14)
- DO F^LRAPF
- DO ^LRAPF
- if LR("Q")
- QUIT
- +9 ;S DIWF="W" ;LR*5.2*464
- +10 ;LR*5.2*464
- SET DIWF="WN"
- +11 SET X=^LR(LRDFN,LRSS,LRI,1.2,LRV,1,B,0)
- DO ^DIWP
- if LR("Q")
- QUIT
- End DoDot:1
- +12 if LR("Q")
- QUIT
- +13 if LRZ
- DO ^DIWW
- +14 QUIT
- +15 ;
- +16 ;
- SGL ; Print Single Report
- +1 NEW LRPTR
- +2 SET LRAPX(1)=""
- +3 DO EN1^LRUPS
- if LRAN=-1
- QUIT
- +4 IF '$PIECE(^LR(LRDFN,LRSS,LRI,0),"^",11)
- Begin DoDot:1
- +5 WRITE $CHAR(7)," Sorry, report not verified.",!
- End DoDot:1
- GOTO SGL
- +6 DO TIUCHK^LRAPUTL(.LRPTR,LRDFN,LRSS,LRI)
- +7 SET LRAP=LRDFN_"^"_LRI
- SET LRSAV=1
- +8 DO EN2^LRUA
- +9 GOTO DEV
- +10 ;
- +11 ;
- A ;
- +1 SET A=0
- FOR
- SET A=$ORDER(^LR(LRDFN,LRSS,LRI,LRV,A))
- if 'A!(LR("Q"))
- QUIT
- Begin DoDot:1
- +2 if $Y>(IOSL-13)
- DO F^LRAPF
- DO ^LRAPF
- if LR("Q")
- QUIT
- +3 WRITE !,$PIECE(^LR(LRDFN,LRSS,LRI,LRV,A,0),"^")
- End DoDot:1
- +4 QUIT
- +5 ;
- +6 ;
- TOP ;
- +1 SET Z=$PIECE(X,"|TOP|",1)_$PIECE(X,"|TOP|",2)
- DO F^LRAPF
- DO ^LRAPF
- SET X=Z
- +2 QUIT
- +3 ;
- +4 ;
- SUPA ; Print supplementary report audit information
- +1 WRITE !?14,"*+* SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED *+*"
- +2 WRITE !,"(Added/Last modified: "
- +3 SET (A,B)=0
- FOR
- SET A=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A))
- if 'A!(LR("Q"))
- QUIT
- Begin DoDot:1
- +4 SET B=A
- End DoDot:1
- +5 if LR("Q")
- QUIT
- +6 if '$DATA(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,B,0))
- QUIT
- +7 SET A=^(0)
- SET Y=+A
- SET LRSGN=" typed by "
- SET A=$PIECE(A,"^",2)
- +8 IF $PIECE(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,B,0),"^",3)
- Begin DoDot:1
- +9 SET A=^(0)
- SET LRSGN=" signed by "
- SET A2=$PIECE(A,"^",3)
- SET Y=$PIECE(A,"^",4)
- +10 SET A=A2
- End DoDot:1
- +11 SET A=$SELECT($DATA(^VA(200,A,0)):$PIECE(^(0),"^"),1:A)
- +12 ; If supp rpt is released, display 'signed by' instead of 'typed by'
- +13 DO D^LRU
- WRITE Y,LRSGN,A,")"
- +14 ; If RELEASE SUPP REPORT MODIFIED set to 1, display "NOT VERIFIED"
- +15 IF $PIECE(^LR(LRDFN,LRSS,LRI,1.2,LRV,0),"^",3)
- WRITE !,?25,"**-* NOT VERIFIED *-**"
- +16 if $DATA(LRQ(9))
- DO SUPM
- +17 QUIT
- +18 ;
- +19 ;
- SUPM ; Print previous versions of supplementary reports
- +1 ; This is used by menu option 'Print path modifications [LRAPMOD]'
- +2 ;
- +3 SET A=0
- FOR
- SET A=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A))
- if 'A!(LR("Q"))
- QUIT
- Begin DoDot:1
- +4 SET LRT=^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A,0)
- +5 if $Y>(IOSL-13)
- DO F^LRAPF
- DO ^LRAPF
- if LR("Q")
- QUIT
- +6 SET Y=+LRT
- SET Y2=" modified: "
- SET X=$PIECE(LRT,"^",2)
- SET LRSGN=" typed by "
- +7 ; If supp rpt is released, display 'signed by' instead of 'typed by'
- +8 IF $PIECE(LRT,"^",3)
- SET LRSGN=" signed by "
- SET X=$PIECE(LRT,"^",3)
- SET Y=$PIECE(LRT,"^",4)
- SET Y2=" released: "
- +9 SET X=$SELECT($DATA(^VA(200,X,0)):$PIECE(^(0),"^"),1:X)
- +10 DO D^LRU
- WRITE !,"Date ",Y2,Y,LRSGN,X
- +11 KILL ^UTILITY($JOB)
- +12 SET DIWR=IOM-5
- SET DIWL=5
- SET DIWF="W"
- +13 SET B=0
- +14 FOR LRZ=0:1
- SET B=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A,1,B))
- if 'B!(LR("Q"))
- QUIT
- Begin DoDot:2
- +15 SET LRT=^LR(LRDFN,LRSS,LRI,1.2,LRV,2,A,1,B,0)
- +16 if $Y>(IOSL-13)
- DO F^LRAPF
- DO ^LRAPF
- if LR("Q")
- QUIT
- +17 SET X=LRT
- DO ^DIWP
- End DoDot:2
- +18 if LR("Q")
- QUIT
- if LRZ
- DO ^DIWW
- End DoDot:1
- +19 if LR("Q")
- QUIT
- +20 WRITE !?13,"==========Text below appears on final report=========="
- +21 QUIT
- +22 ;
- +23 ;
- CONT ;
- +1 KILL DIR
- SET DIR(0)="E"
- +2 DO ^DIR
- WRITE !
- +3 if $DATA(DTOUT)!(X[U)
- SET LR("Q")=1
- +4 QUIT
- +5 ;
- +6 ;
- FOC ; Print final office copy page (SNOMEDS)
- +1 NEW LRADC,LRCTR
- +2 IF '$DATA(LRAP)
- Begin DoDot:1
- +3 if LRSS'="AU"
- DO ^LRUA
- +4 IF LRSS="AU"
- SET X=^LR(LRDFN,0)
- DO ^LRUP
- End DoDot:1
- +5 IF LRSS="AU"
- Begin DoDot:1
- +6 SET LRADC=$EXTRACT($PIECE(^LR(LRDFN,LRSS),"^"),1,3)_"0000"
- +7 if +$GET(LRDPF)=2
- SET LRDEM("DTH")=$PIECE(VADM(6),"^",2)
- +8 ; Get DATE DIED from Referral File for Referral Patients
- +9 if +$GET(LRDPF)'=2
- SET LRDEM("DTH")=$$GET1^DIQ(67,DFN_",",.351)
- +10 SET LRDEM("AUDT")=$$GET1^DIQ(63,LRDFN_",",11)
- +11 SET LRDEM("AUTYP")=$$GET1^DIQ(63,LRDFN_",",13.7)
- +12 SET LRDEM("PRO")=$$GET1^DIQ(63,LRDFN_",",13.5)
- End DoDot:1
- +13 IF LRSS'="AU"
- Begin DoDot:1
- +14 SET LRADC=$EXTRACT($PIECE(^LR(LRDFN,LRSS,LRI,0),"^",10),1,3)_"0000"
- +15 SET LRDEM("PRO")=LRMD
- End DoDot:1
- +16 SET LRDEM("PNM")=LRP
- SET LRDEM("SSN")=SSN
- +17 SET LRDEM("SEX")=SEX
- SET LRDEM("AGE")=AGE
- SET LRDEM("DOB")=DOB
- +18 DO INIT^LRAPSNMD(LRDFN,LRSS,$GET(LRI),LRSF,LRAA,LRAN,LRADC,.LRDEM,0)
- +19 QUIT
- +20 ;
- +21 ;
- END ;
- +1 DO V^LRU
- +2 KILL LRSF515
- +3 QUIT