LRAPBK ;AVAMC/REG/CYM - AP LOG BOOK ;2/9/98 15:36 ; [ 04/11/2003 9:58 AM ]
;;5.2T9;LR;**1002,1006,1018**;Nov 17, 2004
;;5.2;LAB SERVICE;**51,72,201,274**;Sep 27, 1994
; The code for functionality of LR*5.2*51 has changed with patch 72.
; The functionality that came with LR*5.2*51 remains the same.
D ^LRAP G:'$D(Y) END D XR^LRU
W !!?20,LRO(68)," LOG BOOK" S X=$E(DT,2,3),%DT="" D ^%DT S LRH(2)=$E(Y,1,3) D D^LRU S LRH(0)=Y
W !!,"Print SNOMED codes if entered " S %=2 D YN^LRU G:%<1 END S:%=1 LRB=1
I $D(LRB) W !,"Print only Topography and Morphology codes " S %=2 D YN^LRU G:%<1 END S:%=2 LRB(1)=1
W !!,"Log book year: ",LRH(0)," OK " S %=1 D YN^LRU G:%<0 END
ASK I %=2 W ! S %DT("A")="Select YEAR: ",%DT="AQ" D ^%DT K %DT G:Y<1 END S LRH(2)=$E(Y,1,3) D D^LRU S LRH(0)=Y
I '$D(^LR(LRXREF,LRH(2),LRABV)) W $C(7),!!,"No entries for ",LRH(0) S %=2 G ASK
N1 R !,"Start with Acc #: ",X:DTIME G:X=""!(X[U) END I X'?1N.N W $C(7),!!,"NUMBERS ONLY !!" G N1
S LRN(1)=X
N2 R !,"Go to Acc #: LAST // ",X:DTIME G:X='$T!(X[U) END S:X="" X=999999 I X'?1N.N W $C(7),!!,"NUMBERS ONLY !!",!! G N2
S LRN(2)=X,ZTRTN="QUE^LRAPBK",ZTDESC="Anatomic Path Log Book",ZTSAVE("LR*")="" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO D L^LRU,S^LRU S P(9)="",LRW=LRH(2)_"0000" D H S LR("F")=1
S LRAN=LRN(1)-1 F S LRAN=$O(^LR(LRXREF,LRH(2),LRABV,LRAN)) Q:'LRAN!(LRAN>LRN(2))!(LR("Q")) D SH
W:IOST'?1"C".E @IOF D END^LRUTL,END Q
SH S P(13)="",LRDFN=$O(^LR(LRXREF,LRH(2),LRABV,LRAN,0)) Q:'LRDFN!(LR("Q")) I "SPCYEM"[LRSS S LRI=$O(^(LRDFN,0)) Q:'LRI
D:$Y>(IOSL-6) H Q:LR("Q")
K LRDPF,LRLLOC D PT^LRX I $G(LREND) K LREND Q
S LRP=PNM,P(0)=$S(LRDPF=2:"PATIENT",1:"OTHER")
I "SPCYEM"[LRSS Q:'$D(^LR(LRDFN,LRSS,LRI,0)) S X=^(0),LRLLOC=$P(X,U,8),Y=$P(X,U,7) D S S P(2)=Y,Y=$P(X,U,2) D S S P(1)=$E(Y,1,12),Y=$P(X,U,13) D S S P(13)=Y,LRSPDT=$$Y2K^LRX(+X),X=$P(X,U,10)
E Q:'$D(^LR(LRDFN,"AU")) S X=^("AU"),LRLLOC=$P(X,U,5),Y=$P(X,U,12) D S S P(2)=Y,Y=$P(X,U,7) D S S P(9)=$E(Y,1,15),Y=$P(X,U,2) D S S LR("ASST")=Y,Y=$P(X,U,10) D S S P(1)=$E(Y,1,12),X=+X
S T=+$E(X,4,5)_"/"_$E(X,6,7)
;W !,$J(T,5),?7,$J(LRAN,5),?14 W:P(0)'="PATIENT" "#" W $E(LRP,1,18),?34,SSN(1),?40,$E(LRLLOC,1,8),?49,$E(P(2),1,16),?67,P(1),!?10,"SSN: ",SSN
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
W !,$J(T,5),?7,$J(LRAN,5),?14 W:P(0)'="VA PATIENT" "#" W $E(LRP,1,18),?34,HRCN,?40,$E(LRLLOC,1,8),?49,$E(P(2),1,16),?67,P(1) ;IHS/ANMC/CLS 11/1/95
;----- END IHS MODIFICATIONS
S LRLLOC("TY")=$P($G(^LRO(68,LRAA,1,LRH(2)_"0000",1,LRAN,0)),U,11)
S LRLLOC("TY")=$S('$L(LRLLOC("TY")):"InPatient","WI"[LRLLOC("TY"):"InPatient",1:"OutPatient")
W !?5,LRLLOC("TY")
I $L($G(^LRO(68,LRAA,1,LRH(2)_"0000",1,LRAN,.3))) W ?29,"UID: ",^(.3)
D
. N IEN,LRENC,LRX,LRSTR,X,Y
. Q:'$G(^LRO(68,LRAA,1,LRH(2)_"0000",1,LRAN,"PCE")) S LRSTR=^("PCE")
. F IEN=1:1 S LRX=$P(LRSTR,";",IEN) Q:'LRX D GETCPT^PXAPIOE(LRX,"LRENC","ERR")
. Q:'$O(LRENC(0)) W !,"CPT Code: " S IEN=0 F S IEN=$O(LRENC(IEN)) Q:'IEN W $P(LRENC(IEN),U)_"X"_$P(LRENC(IEN),U,16)_" " W:$X>70 !
I "SPCYEM"[LRSS W !,"Date specimen taken:",LRSPDT I $D(^LRO(68,LRAA,1,LRW,1,LRAN,0)) S Y=$P(^(0),"^",10) I Y,$D(^VA(200,Y,0)) W ?37,"Entered by:",$P(^(0),"^")
I P(13)]"" W !?37,"Released by:",P(13)
S Y=+$G(^LRO(68,LRAA,1,LRH(2)_"0000",1,LRAN,.4)) I Y,Y'=DUZ(2) W !,$P($G(^DIC(4,Y,0)),U)
I LRSS="AU" S DA=LRDFN D D^LRAUAW S Y=LR(63,12) D D^LRU W !?14,"Date died: ",Y,?49,"Path resident:",?64,P(9) D AS
I "CYEMSP"[LRSS F Z=0:0 S Z=$O(^LR(LRDFN,LRSS,LRI,.1,Z)) Q:'Z D:$Y>(IOSL-6) H1 Q:LR("Q") W !?2 S Z(1)=$P(^LR(LRDFN,LRSS,LRI,.1,Z,0),"^") W:$L(Z(1))<61 ?14 W Z(1)
Q:LR("Q") I $D(LRB),"CYEMSP"[LRSS,$D(^LR(LRDFN,LRSS,LRI,2,0)) D:$Y>(IOSL-6) H1 Q:LR("Q") W !?14,"SNOMED codes:" D ^LRAPBK1
Q:LR("Q") I $D(LRB),LRSS="AU",$O(^LR(LRDFN,"AY",0)) D:$Y>(IOSL-6) H1 Q:LR("Q") W !?14,"SNOMED codes:" D AU^LRAPBK1
I LRSS'="AU" D D Q:LR("Q")
Q:LR("Q") W !,LR("%") Q
D F Z(1)=99,97 Q:LR("Q") S Z=0 F S Z=$O(^LR(LRDFN,LRSS,LRI,Z(1),Z)) Q:'Z D:$Y>(IOSL-6) H1 Q:LR("Q") W !?4,^LR(LRDFN,LRSS,LRI,Z(1),Z,0)
Q
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,LRO(68)," (",LRABV,") LOG BOOK for ",LRH(0),!
W "# =Demographic data in file other than PATIENT file"
W !,"Date",?8,"Num",?14,"Patient",?35,"ID",?40,"LOC",?49,"PHYSICIAN",?67,"PATHOLOGIST",!,LR("%") Q
H1 ;D H Q:LR("Q") W !,$J(T,5),?7,$J(LRAN,5),?14 W:P(0)'="PATIENT" "#" W $E(LRP,1,18),?34,SSN(1),?40,$E(LRLLOC,1,8),?49,$E(P(2),1,16),?67,P(1) Q
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
D H Q:LR("Q") W !,$J(T,5),?7,$J(LRAN,5),?14 W:P(0)'="VA PATIENT" "#" W $E(LRP,1,18),?34,HRCN,?40,$E(LRLLOC,1,8),?49,$E(P(2),1,16),?67,P(1) Q ;IHS/ANMC/CLS 11/1/95
;----- END IHS MODIFICATIONS
;
S S Y=$P($G(^VA(200,+Y,0)),U) Q
AS I $D(^LRO(68,LRAA,1,LRW,1,LRAN,0)) S Y=$P(^(0),"^",10) D S W ! W:Y]"" ?14,"Entered by: ",Y W:LR("ASST")]"" ?49,"Autopsy Asst: ",LR("ASST")
Q
END K LRSPDT D V^LRU Q
LRAPBK ;AVAMC/REG/CYM - AP LOG BOOK ;2/9/98 15:36 ; [ 04/11/2003 9:58 AM ]
+1 ;;5.2T9;LR;**1002,1006,1018**;Nov 17, 2004
+2 ;;5.2;LAB SERVICE;**51,72,201,274**;Sep 27, 1994
+3 ; The code for functionality of LR*5.2*51 has changed with patch 72.
+4 ; The functionality that came with LR*5.2*51 remains the same.
+5 DO ^LRAP
IF '$DATA(Y)
GOTO END
DO XR^LRU
+6 WRITE !!?20,LRO(68)," LOG BOOK"
SET X=$EXTRACT(DT,2,3)
SET %DT=""
DO ^%DT
SET LRH(2)=$EXTRACT(Y,1,3)
DO D^LRU
SET LRH(0)=Y
+7 WRITE !!,"Print SNOMED codes if entered "
SET %=2
DO YN^LRU
IF %<1
GOTO END
IF %=1
SET LRB=1
+8 IF $DATA(LRB)
WRITE !,"Print only Topography and Morphology codes "
SET %=2
DO YN^LRU
IF %<1
GOTO END
IF %=2
SET LRB(1)=1
+9 WRITE !!,"Log book year: ",LRH(0)," OK "
SET %=1
DO YN^LRU
IF %<0
GOTO END
ASK IF %=2
WRITE !
SET %DT("A")="Select YEAR: "
SET %DT="AQ"
DO ^%DT
KILL %DT
IF Y<1
GOTO END
SET LRH(2)=$EXTRACT(Y,1,3)
DO D^LRU
SET LRH(0)=Y
+1 IF '$DATA(^LR(LRXREF,LRH(2),LRABV))
WRITE $CHAR(7),!!,"No entries for ",LRH(0)
SET %=2
GOTO ASK
N1 READ !,"Start with Acc #: ",X:DTIME
IF X=""!(X[U)
GOTO END
IF X'?1N.N
WRITE $CHAR(7),!!,"NUMBERS ONLY !!"
GOTO N1
+1 SET LRN(1)=X
N2 READ !,"Go to Acc #: LAST // ",X:DTIME
IF X='$TEST!(X[U)
GOTO END
IF X=""
SET X=999999
IF X'?1N.N
WRITE $CHAR(7),!!,"NUMBERS ONLY !!",!!
GOTO N2
+1 SET LRN(2)=X
SET ZTRTN="QUE^LRAPBK"
SET ZTDESC="Anatomic Path Log Book"
SET ZTSAVE("LR*")=""
DO BEG^LRUTL
IF POP!($DATA(ZTSK))
GOTO END
QUE USE IO
DO L^LRU
DO S^LRU
SET P(9)=""
SET LRW=LRH(2)_"0000"
DO H
SET LR("F")=1
+1 SET LRAN=LRN(1)-1
FOR
SET LRAN=$ORDER(^LR(LRXREF,LRH(2),LRABV,LRAN))
IF 'LRAN!(LRAN>LRN(2))!(LR("Q"))
QUIT
DO SH
+2 IF IOST'?1"C".E
WRITE @IOF
DO END^LRUTL
DO END
QUIT
SH SET P(13)=""
SET LRDFN=$ORDER(^LR(LRXREF,LRH(2),LRABV,LRAN,0))
IF 'LRDFN!(LR("Q"))
QUIT
IF "SPCYEM"[LRSS
SET LRI=$ORDER(^(LRDFN,0))
IF 'LRI
QUIT
+1 IF $Y>(IOSL-6)
DO H
IF LR("Q")
QUIT
+2 KILL LRDPF,LRLLOC
DO PT^LRX
IF $GET(LREND)
KILL LREND
QUIT
+3 SET LRP=PNM
SET P(0)=$SELECT(LRDPF=2:"PATIENT",1:"OTHER")
+4 IF "SPCYEM"[LRSS
IF '$DATA(^LR(LRDFN,LRSS,LRI,0))
QUIT
SET X=^(0)
SET LRLLOC=$PIECE(X,U,8)
SET Y=$PIECE(X,U,7)
DO S
SET P(2)=Y
SET Y=$PIECE(X,U,2)
DO S
SET P(1)=$EXTRACT(Y,1,12)
SET Y=$PIECE(X,U,13)
DO S
SET P(13)=Y
SET LRSPDT=$$Y2K^LRX(+X)
SET X=$PIECE(X,U,10)
+5 IF '$TEST
IF '$DATA(^LR(LRDFN,"AU"))
QUIT
SET X=^("AU")
SET LRLLOC=$PIECE(X,U,5)
SET Y=$PIECE(X,U,12)
DO S
SET P(2)=Y
SET Y=$PIECE(X,U,7)
DO S
SET P(9)=$EXTRACT(Y,1,15)
SET Y=$PIECE(X,U,2)
DO S
SET LR("ASST")=Y
SET Y=$PIECE(X,U,10)
DO S
SET P(1)=$EXTRACT(Y,1,12)
SET X=+X
+6 SET T=+$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)
+7 ;W !,$J(T,5),?7,$J(LRAN,5),?14 W:P(0)'="PATIENT" "#" W $E(LRP,1,18),?34,SSN(1),?40,$E(LRLLOC,1,8),?49,$E(P(2),1,16),?67,P(1),!?10,"SSN: ",SSN
+8 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+9 ;IHS/ANMC/CLS 11/1/95
WRITE !,$JUSTIFY(T,5),?7,$JUSTIFY(LRAN,5),?14
IF P(0)'="VA PATIENT"
WRITE "#"
WRITE $EXTRACT(LRP,1,18),?34,HRCN,?40,$EXTRACT(LRLLOC,1,8),?49,$EXTRACT(P(2),1,16),?67,P(1)
+10 ;----- END IHS MODIFICATIONS
+11 SET LRLLOC("TY")=$PIECE($GET(^LRO(68,LRAA,1,LRH(2)_"0000",1,LRAN,0)),U,11)
+12 SET LRLLOC("TY")=$SELECT('$LENGTH(LRLLOC("TY")):"InPatient","WI"[LRLLOC("TY"):"InPatient",1:"OutPatient")
+13 WRITE !?5,LRLLOC("TY")
+14 IF $LENGTH($GET(^LRO(68,LRAA,1,LRH(2)_"0000",1,LRAN,.3)))
WRITE ?29,"UID: ",^(.3)
+15 Begin DoDot:1
+16 NEW IEN,LRENC,LRX,LRSTR,X,Y
+17 IF '$GET(^LRO(68,LRAA,1,LRH(2)_"0000",1,LRAN,"PCE"))
QUIT
SET LRSTR=^("PCE")
+18 FOR IEN=1:1
SET LRX=$PIECE(LRSTR,";",IEN)
IF 'LRX
QUIT
DO GETCPT^PXAPIOE(LRX,"LRENC","ERR")
+19 IF '$ORDER(LRENC(0))
QUIT
WRITE !,"CPT Code: "
SET IEN=0
FOR
SET IEN=$ORDER(LRENC(IEN))
IF 'IEN
QUIT
WRITE $PIECE(LRENC(IEN),U)_"X"_$PIECE(LRENC(IEN),U,16)_" "
IF $X>70
WRITE !
End DoDot:1
+20 IF "SPCYEM"[LRSS
WRITE !,"Date specimen taken:",LRSPDT
IF $DATA(^LRO(68,LRAA,1,LRW,1,LRAN,0))
SET Y=$PIECE(^(0),"^",10)
IF Y
IF $DATA(^VA(200,Y,0))
WRITE ?37,"Entered by:",$PIECE(^(0),"^")
+21 IF P(13)]""
WRITE !?37,"Released by:",P(13)
+22 SET Y=+$GET(^LRO(68,LRAA,1,LRH(2)_"0000",1,LRAN,.4))
IF Y
IF Y'=DUZ(2)
WRITE !,$PIECE($GET(^DIC(4,Y,0)),U)
+23 IF LRSS="AU"
SET DA=LRDFN
DO D^LRAUAW
SET Y=LR(63,12)
DO D^LRU
WRITE !?14,"Date died: ",Y,?49,"Path resident:",?64,P(9)
DO AS
+24 IF "CYEMSP"[LRSS
FOR Z=0:0
SET Z=$ORDER(^LR(LRDFN,LRSS,LRI,.1,Z))
IF 'Z
QUIT
IF $Y>(IOSL-6)
DO H1
IF LR("Q")
QUIT
WRITE !?2
SET Z(1)=$PIECE(^LR(LRDFN,LRSS,LRI,.1,Z,0),"^")
IF $LENGTH(Z(1))<61
WRITE ?14
WRITE Z(1)
+25 IF LR("Q")
QUIT
IF $DATA(LRB)
IF "CYEMSP"[LRSS
IF $DATA(^LR(LRDFN,LRSS,LRI,2,0))
IF $Y>(IOSL-6)
DO H1
IF LR("Q")
QUIT
WRITE !?14,"SNOMED codes:"
DO ^LRAPBK1
+26 IF LR("Q")
QUIT
IF $DATA(LRB)
IF LRSS="AU"
IF $ORDER(^LR(LRDFN,"AY",0))
IF $Y>(IOSL-6)
DO H1
IF LR("Q")
QUIT
WRITE !?14,"SNOMED codes:"
DO AU^LRAPBK1
+27 IF LRSS'="AU"
DO D
IF LR("Q")
QUIT
+28 IF LR("Q")
QUIT
WRITE !,LR("%")
QUIT
D FOR Z(1)=99,97
IF LR("Q")
QUIT
SET Z=0
FOR
SET Z=$ORDER(^LR(LRDFN,LRSS,LRI,Z(1),Z))
IF 'Z
QUIT
IF $Y>(IOSL-6)
DO H1
IF LR("Q")
QUIT
WRITE !?4,^LR(LRDFN,LRSS,LRI,Z(1),Z,0)
+1 QUIT
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
IF LR("Q")
QUIT
+1 DO F^LRU
WRITE !,LRO(68)," (",LRABV,") LOG BOOK for ",LRH(0),!
+2 WRITE "# =Demographic data in file other than PATIENT file"
+3 WRITE !,"Date",?8,"Num",?14,"Patient",?35,"ID",?40,"LOC",?49,"PHYSICIAN",?67,"PATHOLOGIST",!,LR("%")
QUIT
H1 ;D H Q:LR("Q") W !,$J(T,5),?7,$J(LRAN,5),?14 W:P(0)'="PATIENT" "#" W $E(LRP,1,18),?34,SSN(1),?40,$E(LRLLOC,1,8),?49,$E(P(2),1,16),?67,P(1) Q
+1 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+2 ;IHS/ANMC/CLS 11/1/95
DO H
IF LR("Q")
QUIT
WRITE !,$JUSTIFY(T,5),?7,$JUSTIFY(LRAN,5),?14
IF P(0)'="VA PATIENT"
WRITE "#"
WRITE $EXTRACT(LRP,1,18),?34,HRCN,?40,$EXTRACT(LRLLOC,1,8),?49,$EXTRACT(P(2),1,16),?67,P(1)
QUIT
+3 ;----- END IHS MODIFICATIONS
+4 ;
S SET Y=$PIECE($GET(^VA(200,+Y,0)),U)
QUIT
AS IF $DATA(^LRO(68,LRAA,1,LRW,1,LRAN,0))
SET Y=$PIECE(^(0),"^",10)
DO S
WRITE !
IF Y]""
WRITE ?14,"Entered by: ",Y
IF LR("ASST")]""
WRITE ?49,"Autopsy Asst: ",LR("ASST")
+1 QUIT
END KILL LRSPDT
DO V^LRU
QUIT
