- 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 Jan 18, 2025@03:09:10 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