- LRSPRPT2 ;AVAMC/REG/WTY - SURG PATH PRINT SNOMED;09/06/01
- ;;5.2;LAB SERVICE;**72,259**;Sep 27, 1994
- ;
- D:$Y>(IOSL-13) F Q:LR("Q")
- I $D(^LR(LRDFN,LRSS,LRI,2,A)) W !,"SNOMED code(s):"
- S A=0 F S A=$O(^LR(LRDFN,LRSS,LRI,2,A)) Q:'A!(LR("Q")) D
- .S T=+^LR(LRDFN,LRSS,LRI,2,A,0),T=^LAB(61,T,0)
- .D:$Y>(IOSL-12) F Q:LR("Q")
- .W !,"T-",$P(T,"^",2),": "
- .S X=$P(T,"^") D:LR(69.2,.05) C^LRUA W X
- .D M
- Q
- M ;
- S B=0 F S B=$O(^LR(LRDFN,LRSS,LRI,2,A,2,B)) Q:'B!(LR("Q")) D
- .S M=+^LR(LRDFN,LRSS,LRI,2,A,2,B,0),M=^LAB(61.1,M,0)
- .D:$Y>(IOSL-12) F Q:LR("Q")
- .W !?5,"M-",$P(M,"^",2),": "
- .S X=$P(M,"^") D:LR(69.2,.05) C^LRUA W X
- .D E
- D ;
- Q:LR("Q")
- F B=1.4,3.3,4.5 D
- .S C=0 F S C=$O(^LR(LRDFN,LRSS,LRI,2,A,$P(B,"."),C)) Q:'C!(LR("Q")) D
- ..S X=^LR(LRDFN,LRSS,LRI,2,A,$P(B,"."),C,0)
- ..D A
- Q
- A ;
- S M=+X,M(2)=$P(X,"^",2),E="61."_$P(B,".",2),M=^LAB(E,M,0)
- D:$Y>(IOSL-12) F Q:LR("Q")
- W !?5,$S(B=1.4:"D-",B=3.3:"F-",B=4.5:"P-",1:""),$P(M,"^",2),?12,": "
- S X=$P(M,"^") D:LR(69.2,.05) C^LRUA W X
- I B=4.5,M(2)]"" D W
- Q
- E ;
- S C=0 F S C=$O(^LR(LRDFN,LRSS,LRI,2,A,2,B,1,C)) Q:'C!(LR("Q")) D
- .S E=+^LR(LRDFN,LRSS,LRI,2,A,2,B,1,C,0),E=^LAB(61.2,E,0)
- .D:$Y>(IOSL-12) F Q:LR("Q")
- .W !?10,"E-",$P(E,"^",2),": " S X=$P(E,"^") D:LR(69.2,.05) C^LRUA W X
- Q
- F ;
- D F^LRAPF,^LRAPF
- Q
- W ;
- W " (",$S(M(2)=0:"negative",M(2)=1:"positive",1:"?"),")"
- Q
- EN ;from LRSPRPT,LRSPT
- Q:'LRAPX(1)
- W !!,"Add/Delete reports to/from print queue for ",LRH(0)," "
- S %=2 D YN^LRU I %=1 D AD
- I '$O(^LRO(69.2,LRAA,LRAPX(1),0)) D Q
- .W $C(7),!!,"NO ",$S(LRAPX(1)=2:"FINAL",1:"PRELIMINARY")
- .W " REPORTS CURRRENTLY ON THE PRINT QUEUE" S %=0
- Q
- AD ;
- D XR^LRU S LRY=$E(LRAD,1,3),LRY(1)=LRY+1700
- I '$O(^LR(LRXREF,LRY,LRABV,0)) D Q
- .W $C(7),!,"No accessions for ",LRY(1)
- ACC ;
- W !!,"Select ",LRO(68)," accession number: " R X:DTIME Q:X=""!(X[U)
- I +X'=X W $C(7),!,"Enter NUMBERS only." G ACC
- I '$O(^LR(LRXREF,LRY,LRABV,X,0)) D G ACC
- .W $C(7),!,"Accession number doesn't exist for ",LRY(1)
- S LRDFN=$O(^LR(LRXREF,LRY,LRABV,X,0)),LRI=$O(^(LRDFN,0))
- S LRAN=X,X=^LR(LRDFN,0) D ^LRUP W !,LRP," ID: ",SSN
- I $D(^LRO(69.2,LRAA,LRAPX(1),LRAN,0)) D DEL G ACC
- I LRAPX(1)=2,'$P(^LR(LRDFN,LRSS,LRI,0),"^",3) D G ACC
- .W $C(7),!,LRO(68)," Accession ",LRAN," for ",LRH(0),!,"does not "
- .W "have a complete date."
- W !!,"Add ",LRO(68)," accession ",LRAN," for ",LRY(1)," to"
- W !,$S(LRAPX(1)=2:"final",1:"preliminary")," rpt print queue "
- S %=2 D YN^LRU D:%=1 ADD
- G ACC
- DEL ;
- W !!,"Delete ",LRO(68)," accession ",LRAN," for ",LRY(1),!,"from "
- W $S(LRAPX(1)=2:"final",1:"preliminary")," rpt print queue "
- S %=2 D YN^LRU Q:%'=1
- K ^LRO(69.2,LRAA,LRAPX(1),LRAN)
- L +^LRO(69.2,LRAA,LRAPX(1))
- S X=^LRO(69.2,LRAA,LRAPX(1),0)
- S X(1)=$O(^LRO(69.2,LRAA,LRAPX(1),0))
- S ^LRO(69.2,LRAA,LRAPX(1),0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-1)
- L -^LRO(69.2,LRAA,LRAPX(1))
- Q
- ADD ;
- S ^LRO(69.2,LRAA,LRAPX(1),LRAN,0)=LRDFN_"^"_LRI_"^"_LRH(0)
- L +^LRO(69.2,LRAA,LRAPX(1))
- S X=^LRO(69.2,LRAA,LRAPX(1),0)
- S ^LRO(69.2,LRAA,LRAPX(1),0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
- L -^LRO(69.2,LRAA,LRAPX(1))
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSPRPT2 3160 printed Jan 18, 2025@03:21:22 Page 2
- LRSPRPT2 ;AVAMC/REG/WTY - SURG PATH PRINT SNOMED;09/06/01
- +1 ;;5.2;LAB SERVICE;**72,259**;Sep 27, 1994
- +2 ;
- +3 if $Y>(IOSL-13)
- DO F
- if LR("Q")
- QUIT
- +4 IF $DATA(^LR(LRDFN,LRSS,LRI,2,A))
- WRITE !,"SNOMED code(s):"
- +5 SET A=0
- FOR
- SET A=$ORDER(^LR(LRDFN,LRSS,LRI,2,A))
- if 'A!(LR("Q"))
- QUIT
- Begin DoDot:1
- +6 SET T=+^LR(LRDFN,LRSS,LRI,2,A,0)
- SET T=^LAB(61,T,0)
- +7 if $Y>(IOSL-12)
- DO F
- if LR("Q")
- QUIT
- +8 WRITE !,"T-",$PIECE(T,"^",2),": "
- +9 SET X=$PIECE(T,"^")
- if LR(69.2,.05)
- DO C^LRUA
- WRITE X
- +10 DO M
- End DoDot:1
- +11 QUIT
- M ;
- +1 SET B=0
- FOR
- SET B=$ORDER(^LR(LRDFN,LRSS,LRI,2,A,2,B))
- if 'B!(LR("Q"))
- QUIT
- Begin DoDot:1
- +2 SET M=+^LR(LRDFN,LRSS,LRI,2,A,2,B,0)
- SET M=^LAB(61.1,M,0)
- +3 if $Y>(IOSL-12)
- DO F
- if LR("Q")
- QUIT
- +4 WRITE !?5,"M-",$PIECE(M,"^",2),": "
- +5 SET X=$PIECE(M,"^")
- if LR(69.2,.05)
- DO C^LRUA
- WRITE X
- +6 DO E
- End DoDot:1
- D ;
- +1 if LR("Q")
- QUIT
- +2 FOR B=1.4,3.3,4.5
- Begin DoDot:1
- +3 SET C=0
- FOR
- SET C=$ORDER(^LR(LRDFN,LRSS,LRI,2,A,$PIECE(B,"."),C))
- if 'C!(LR("Q"))
- QUIT
- Begin DoDot:2
- +4 SET X=^LR(LRDFN,LRSS,LRI,2,A,$PIECE(B,"."),C,0)
- +5 DO A
- End DoDot:2
- End DoDot:1
- +6 QUIT
- A ;
- +1 SET M=+X
- SET M(2)=$PIECE(X,"^",2)
- SET E="61."_$PIECE(B,".",2)
- SET M=^LAB(E,M,0)
- +2 if $Y>(IOSL-12)
- DO F
- if LR("Q")
- QUIT
- +3 WRITE !?5,$SELECT(B=1.4:"D-",B=3.3:"F-",B=4.5:"P-",1:""),$PIECE(M,"^",2),?12,": "
- +4 SET X=$PIECE(M,"^")
- if LR(69.2,.05)
- DO C^LRUA
- WRITE X
- +5 IF B=4.5
- IF M(2)]""
- DO W
- +6 QUIT
- E ;
- +1 SET C=0
- FOR
- SET C=$ORDER(^LR(LRDFN,LRSS,LRI,2,A,2,B,1,C))
- if 'C!(LR("Q"))
- QUIT
- Begin DoDot:1
- +2 SET E=+^LR(LRDFN,LRSS,LRI,2,A,2,B,1,C,0)
- SET E=^LAB(61.2,E,0)
- +3 if $Y>(IOSL-12)
- DO F
- if LR("Q")
- QUIT
- +4 WRITE !?10,"E-",$PIECE(E,"^",2),": "
- SET X=$PIECE(E,"^")
- if LR(69.2,.05)
- DO C^LRUA
- WRITE X
- End DoDot:1
- +5 QUIT
- F ;
- +1 DO F^LRAPF
- DO ^LRAPF
- +2 QUIT
- W ;
- +1 WRITE " (",$SELECT(M(2)=0:"negative",M(2)=1:"positive",1:"?"),")"
- +2 QUIT
- EN ;from LRSPRPT,LRSPT
- +1 if 'LRAPX(1)
- QUIT
- +2 WRITE !!,"Add/Delete reports to/from print queue for ",LRH(0)," "
- +3 SET %=2
- DO YN^LRU
- IF %=1
- DO AD
- +4 IF '$ORDER(^LRO(69.2,LRAA,LRAPX(1),0))
- Begin DoDot:1
- +5 WRITE $CHAR(7),!!,"NO ",$SELECT(LRAPX(1)=2:"FINAL",1:"PRELIMINARY")
- +6 WRITE " REPORTS CURRRENTLY ON THE PRINT QUEUE"
- SET %=0
- End DoDot:1
- QUIT
- +7 QUIT
- AD ;
- +1 DO XR^LRU
- SET LRY=$EXTRACT(LRAD,1,3)
- SET LRY(1)=LRY+1700
- +2 IF '$ORDER(^LR(LRXREF,LRY,LRABV,0))
- Begin DoDot:1
- +3 WRITE $CHAR(7),!,"No accessions for ",LRY(1)
- End DoDot:1
- QUIT
- ACC ;
- +1 WRITE !!,"Select ",LRO(68)," accession number: "
- READ X:DTIME
- if X=""!(X[U)
- QUIT
- +2 IF +X'=X
- WRITE $CHAR(7),!,"Enter NUMBERS only."
- GOTO ACC
- +3 IF '$ORDER(^LR(LRXREF,LRY,LRABV,X,0))
- Begin DoDot:1
- +4 WRITE $CHAR(7),!,"Accession number doesn't exist for ",LRY(1)
- End DoDot:1
- GOTO ACC
- +5 SET LRDFN=$ORDER(^LR(LRXREF,LRY,LRABV,X,0))
- SET LRI=$ORDER(^(LRDFN,0))
- +6 SET LRAN=X
- SET X=^LR(LRDFN,0)
- DO ^LRUP
- WRITE !,LRP," ID: ",SSN
- +7 IF $DATA(^LRO(69.2,LRAA,LRAPX(1),LRAN,0))
- DO DEL
- GOTO ACC
- +8 IF LRAPX(1)=2
- IF '$PIECE(^LR(LRDFN,LRSS,LRI,0),"^",3)
- Begin DoDot:1
- +9 WRITE $CHAR(7),!,LRO(68)," Accession ",LRAN," for ",LRH(0),!,"does not "
- +10 WRITE "have a complete date."
- End DoDot:1
- GOTO ACC
- +11 WRITE !!,"Add ",LRO(68)," accession ",LRAN," for ",LRY(1)," to"
- +12 WRITE !,$SELECT(LRAPX(1)=2:"final",1:"preliminary")," rpt print queue "
- +13 SET %=2
- DO YN^LRU
- if %=1
- DO ADD
- +14 GOTO ACC
- DEL ;
- +1 WRITE !!,"Delete ",LRO(68)," accession ",LRAN," for ",LRY(1),!,"from "
- +2 WRITE $SELECT(LRAPX(1)=2:"final",1:"preliminary")," rpt print queue "
- +3 SET %=2
- DO YN^LRU
- if %'=1
- QUIT
- +4 KILL ^LRO(69.2,LRAA,LRAPX(1),LRAN)
- +5 LOCK +^LRO(69.2,LRAA,LRAPX(1))
- +6 SET X=^LRO(69.2,LRAA,LRAPX(1),0)
- +7 SET X(1)=$ORDER(^LRO(69.2,LRAA,LRAPX(1),0))
- +8 SET ^LRO(69.2,LRAA,LRAPX(1),0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_($PIECE(X,"^",4)-1)
- +9 LOCK -^LRO(69.2,LRAA,LRAPX(1))
- +10 QUIT
- ADD ;
- +1 SET ^LRO(69.2,LRAA,LRAPX(1),LRAN,0)=LRDFN_"^"_LRI_"^"_LRH(0)
- +2 LOCK +^LRO(69.2,LRAA,LRAPX(1))
- +3 SET X=^LRO(69.2,LRAA,LRAPX(1),0)
- +4 SET ^LRO(69.2,LRAA,LRAPX(1),0)=$PIECE(X,"^",1,2)_"^"_LRAN_"^"_($PIECE(X,"^",4)+1)
- +5 LOCK -^LRO(69.2,LRAA,LRAPX(1))
- +6 QUIT