source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRAPBK.m@ 802

Last change on this file since 802 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.2 KB
Line 
1LRAPBK ;AVAMC/REG/CYM - AP LOG BOOK ;2/9/98 15:36 ;
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 D ^LRAP G:'$D(Y) END D XR^LRU
6 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
7 W !!,"Print SNOMED codes if entered " S %=2 D YN^LRU G:%<1 END S:%=1 LRB=1
8 I $D(LRB) W !,"Print only Topography and Morphology codes " S %=2 D YN^LRU G:%<1 END S:%=2 LRB(1)=1
9 W !!,"Log book year: ",LRH(0)," OK " S %=1 D YN^LRU G:%<0 END
10ASK 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
11 I '$D(^LR(LRXREF,LRH(2),LRABV)) W $C(7),!!,"No entries for ",LRH(0) S %=2 G ASK
12N1 R !,"Start with Acc #: ",X:DTIME G:X=""!(X[U) END I X'?1N.N W $C(7),!!,"NUMBERS ONLY !!" G N1
13 S LRN(1)=X
14N2 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
15 S LRN(2)=X,ZTRTN="QUE^LRAPBK",ZTDESC="Anatomic Path Log Book",ZTSAVE("LR*")="" D BEG^LRUTL G:POP!($D(ZTSK)) END
16QUE U IO D L^LRU,S^LRU S P(9)="",LRW=LRH(2)_"0000" D H S LR("F")=1
17 S LRAN=LRN(1)-1 F S LRAN=$O(^LR(LRXREF,LRH(2),LRABV,LRAN)) Q:'LRAN!(LRAN>LRN(2))!(LR("Q")) D SH
18 W:IOST'?1"C".E @IOF D END^LRUTL,END Q
19SH 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
20 D:$Y>(IOSL-6) H Q:LR("Q")
21 K LRDPF,LRLLOC D PT^LRX I $G(LREND) K LREND Q
22 S LRP=PNM,P(0)=$S(LRDPF=2:"PATIENT",1:"OTHER")
23 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)
24 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
25 S T=+$E(X,4,5)_"/"_$E(X,6,7)
26 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
27 S LRLLOC("TY")=$P($G(^LRO(68,LRAA,1,LRH(2)_"0000",1,LRAN,0)),U,11)
28 S LRLLOC("TY")=$S('$L(LRLLOC("TY")):"InPatient","WI"[LRLLOC("TY"):"InPatient",1:"OutPatient")
29 W !?5,LRLLOC("TY")
30 I $L($G(^LRO(68,LRAA,1,LRH(2)_"0000",1,LRAN,.3))) W ?29,"UID: ",^(.3)
31 D
32 . N IEN,LRENC,LRX,LRSTR,X,Y
33 . Q:'$G(^LRO(68,LRAA,1,LRH(2)_"0000",1,LRAN,"PCE")) S LRSTR=^("PCE")
34 . F IEN=1:1 S LRX=$P(LRSTR,";",IEN) Q:'LRX D GETCPT^PXAPIOE(LRX,"LRENC","ERR")
35 . 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 !
36 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),"^")
37 I P(13)]"" W !?37,"Released by:",P(13)
38 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)
39 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
40 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)
41 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
42 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
43 I LRSS'="AU" D D Q:LR("Q")
44 Q:LR("Q") W !,LR("%") Q
45D 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)
46 Q
47H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
48 D F^LRU W !,LRO(68)," (",LRABV,") LOG BOOK for ",LRH(0),!
49 W "# =Demographic data in file other than PATIENT file"
50 W !,"Date",?8,"Num",?14,"Patient",?35,"ID",?40,"LOC",?49,"PHYSICIAN",?67,"PATHOLOGIST",!,LR("%") Q
51H1 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
52 ;
53S S Y=$P($G(^VA(200,+Y,0)),U) Q
54AS 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")
55 Q
56END K LRSPDT D V^LRU Q
Note: See TracBrowser for help on using the repository browser.