- 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
