LRAPT ;AVAMC/REG/WTY - AP PATIENT RPT ;9/22/00
;;5.2;LAB SERVICE;**72,173,248**;Sep 27, 1994
;
;Reference to ^%DT supported by IA #10003
;Reference to ^%ZIS supported by IA #10086
;Reference to ^DIC( supported by IA #916
;Reference to $$DTIME^XUP supported by IA # -none available-
;
D END S X="T",%DT="" D ^%DT S LRT=Y D D^LRU S LRTOD=Y
S IOP="HOME" D ^%ZIS
W @IOF,!?28,"Cum path data summaries"
S DTIME=$$DTIME^XUP(DUZ),U="^"
ASK W !!?14,"1. DISPLAY cum path data summary for A patient"
W !?14,"2. PRINT cum path data summary for patient(s)",!
R "Select (1-2): ",X:DTIME G:X=""!(X[U) END
G:X?1"1".E!(X?1"D".E) ^LRAPS
I X'?1"2".E&(X'?1"P".E) W $C(7),!!,"Answer 1 or 2",! G ASK
S LRDICS="SP",(LRDICS(1),LRDICS(2))=1 D ^LRAP G:'$D(Y) END
D ^LRUL I '$O(^LRO(69.2,LRAA,7,DUZ,1,0)) D R^LRUL G END
K DIC,DIE,DR S ZTRTN="QUE^LRAPT" D BEG^LRUTL
D:POP R^LRUL G:POP!($D(ZTSK)) END
QUE U IO S (LRS(5),LRQ(9))=1 D L^LRU,S^LRU,EN^LRUA
S PNM=0
F PNM(1)=0:0 S PNM=$O(^LRO(69.2,LRAA,7,DUZ,1,"C",PNM)) Q:PNM=""!(LR("Q")) D
.F LRDFN=0:0 S LRDFN=$O(^LRO(69.2,LRAA,7,DUZ,1,"C",PNM,LRDFN)) Q:'LRDFN!(LR("Q")) D
..D LOOP
K LRAU
W:IOST'?1"C".E&($E(IOST,1,2)'="P-"!($D(LR("FORM")))) @IOF
D R^LRUL,END^LRUTL,END
Q
LOOP K ^LRO(69.2,LRAA,7,DUZ,1,LRDFN),^LRO(69.2,LRAA,7,DUZ,1,"C",PNM,LRDFN)
L +^LRO(69.2,LRAA,7,DUZ):1 Q:'$T
S X(1)=$O(^LRO(69.2,LRAA,7,DUZ,1,0)),X=^(0),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-1)
L -^LRO(69.2,LRAA,7,DUZ)
S DR=1,LRQ=0,LRDPF=$P(^LR(LRDFN,0),U,2),LRPF=^DIC(LRDPF,0,"GL")
S LRFLN=+$P(@(LRPF_"0)"),"^",2),DFN=$P(^LR(LRDFN,0),"^",3)
S LRPPT=@(LRPF_DFN_",0)")
S LRP=$P(LRPPT,"^"),SEX=$P(LRPPT,"^",2),Y=$P(LRPPT,"^",3),SSN=$P(LRPPT,"^",9) D D^LRU,SSN^LRU S DOB=$S(Y[1700:"",1:Y)
S (LRADM,LRADX)=""
S LRLLOC=$S($D(@(LRPF_DFN_",.1)")):^(.1),$D(^LR(LRDFN,.1)):^(.1),1:"")
I LRPF="^DPT(",$D(VAIN) S LRADM=$P(VAIN(7),U,2),LRADX=VAIN(9)
G:'$D(^LR(LRDFN,"SP"))&('$D(^LR(LRDFN,"CY")))&('$D(^LR(LRDFN,"EM"))) AU
D ^LRAPT1 S LRV(1)=1
AU Q:LR("Q") I $D(^LR(LRDFN,"AU")),+^("AU") S LRV(1)=1 D ^LRAPT2
Q:LR("Q") I '$D(LRV(1)) D H^LRAPT1 W !!,"NO PATHOLOGY ENTRIES IN LAB FILE !",!
Q
H ;from LRAPT2, LRAPT3
I $D(LR("F")),$E(IOST,1,2)["C-" D M^LRU Q:LR("Q")
D F^LRU W !,"ANATOMIC PATHOLOGY" W:$D(LR("W")) !,LRAA(1)," QA from ",LRSTR," to ",LRLST W !,LR("%") Q
H1 D H Q:LR("Q") W !,LRP,?32,SSN,?52,"DOB:",DOB Q
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPT 2420 printed Dec 13, 2024@02:08:27 Page 2
LRAPT ;AVAMC/REG/WTY - AP PATIENT RPT ;9/22/00
+1 ;;5.2;LAB SERVICE;**72,173,248**;Sep 27, 1994
+2 ;
+3 ;Reference to ^%DT supported by IA #10003
+4 ;Reference to ^%ZIS supported by IA #10086
+5 ;Reference to ^DIC( supported by IA #916
+6 ;Reference to $$DTIME^XUP supported by IA # -none available-
+7 ;
+8 DO END
SET X="T"
SET %DT=""
DO ^%DT
SET LRT=Y
DO D^LRU
SET LRTOD=Y
+9 SET IOP="HOME"
DO ^%ZIS
+10 WRITE @IOF,!?28,"Cum path data summaries"
+11 SET DTIME=$$DTIME^XUP(DUZ)
SET U="^"
ASK WRITE !!?14,"1. DISPLAY cum path data summary for A patient"
+1 WRITE !?14,"2. PRINT cum path data summary for patient(s)",!
+2 READ "Select (1-2): ",X:DTIME
if X=""!(X[U)
GOTO END
+3 if X?1"1".E!(X?1"D".E)
GOTO ^LRAPS
+4 IF X'?1"2".E&(X'?1"P".E)
WRITE $CHAR(7),!!,"Answer 1 or 2",!
GOTO ASK
+5 SET LRDICS="SP"
SET (LRDICS(1),LRDICS(2))=1
DO ^LRAP
if '$DATA(Y)
GOTO END
+6 DO ^LRUL
IF '$ORDER(^LRO(69.2,LRAA,7,DUZ,1,0))
DO R^LRUL
GOTO END
+7 KILL DIC,DIE,DR
SET ZTRTN="QUE^LRAPT"
DO BEG^LRUTL
+8 if POP
DO R^LRUL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
SET (LRS(5),LRQ(9))=1
DO L^LRU
DO S^LRU
DO EN^LRUA
+1 SET PNM=0
+2 FOR PNM(1)=0:0
SET PNM=$ORDER(^LRO(69.2,LRAA,7,DUZ,1,"C",PNM))
if PNM=""!(LR("Q"))
QUIT
Begin DoDot:1
+3 FOR LRDFN=0:0
SET LRDFN=$ORDER(^LRO(69.2,LRAA,7,DUZ,1,"C",PNM,LRDFN))
if 'LRDFN!(LR("Q"))
QUIT
Begin DoDot:2
+4 DO LOOP
End DoDot:2
End DoDot:1
+5 KILL LRAU
+6 if IOST'?1"C".E&($EXTRACT(IOST,1,2)'="P-"!($DATA(LR("FORM"))))
WRITE @IOF
+7 DO R^LRUL
DO END^LRUTL
DO END
+8 QUIT
LOOP KILL ^LRO(69.2,LRAA,7,DUZ,1,LRDFN),^LRO(69.2,LRAA,7,DUZ,1,"C",PNM,LRDFN)
+1 LOCK +^LRO(69.2,LRAA,7,DUZ):1
if '$TEST
QUIT
+2 SET X(1)=$ORDER(^LRO(69.2,LRAA,7,DUZ,1,0))
SET X=^(0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_($PIECE(X,"^",4)-1)
+3 LOCK -^LRO(69.2,LRAA,7,DUZ)
+4 SET DR=1
SET LRQ=0
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET LRPF=^DIC(LRDPF,0,"GL")
+5 SET LRFLN=+$PIECE(@(LRPF_"0)"),"^",2)
SET DFN=$PIECE(^LR(LRDFN,0),"^",3)
+6 SET LRPPT=@(LRPF_DFN_",0)")
+7 SET LRP=$PIECE(LRPPT,"^")
SET SEX=$PIECE(LRPPT,"^",2)
SET Y=$PIECE(LRPPT,"^",3)
SET SSN=$PIECE(LRPPT,"^",9)
DO D^LRU
DO SSN^LRU
SET DOB=$SELECT(Y[1700:"",1:Y)
+8 SET (LRADM,LRADX)=""
+9 SET LRLLOC=$SELECT($DATA(@(LRPF_DFN_",.1)")):^(.1),$DATA(^LR(LRDFN,.1)):^(.1),1:"")
+10 IF LRPF="^DPT("
IF $DATA(VAIN)
SET LRADM=$PIECE(VAIN(7),U,2)
SET LRADX=VAIN(9)
+11 if '$DATA(^LR(LRDFN,"SP"))&('$DATA(^LR(LRDFN,"CY")))&('$DATA(^LR(LRDFN,"EM")))
GOTO AU
+12 DO ^LRAPT1
SET LRV(1)=1
AU if LR("Q")
QUIT
IF $DATA(^LR(LRDFN,"AU"))
IF +^("AU")
SET LRV(1)=1
DO ^LRAPT2
+1 if LR("Q")
QUIT
IF '$DATA(LRV(1))
DO H^LRAPT1
WRITE !!,"NO PATHOLOGY ENTRIES IN LAB FILE !",!
+2 QUIT
H ;from LRAPT2, LRAPT3
+1 IF $DATA(LR("F"))
IF $EXTRACT(IOST,1,2)["C-"
DO M^LRU
if LR("Q")
QUIT
+2 DO F^LRU
WRITE !,"ANATOMIC PATHOLOGY"
if $DATA(LR("W"))
WRITE !,LRAA(1)," QA from ",LRSTR," to ",LRLST
WRITE !,LR("%")
QUIT
H1 DO H
if LR("Q")
QUIT
WRITE !,LRP,?32,SSN,?52,"DOB:",DOB
QUIT
+1 ;
END DO V^LRU
QUIT
