LRACSUM ;SLC/DCM - INDIVIDUAL PATIENT SUMMARY. ;4/17/91 14:30 ;
;;5.2;LAB SERVICE;**27,201**;Sep 27, 1994
DFN S LRIN=0,LRIDT=0,LREND=0,LROUT=9999999,LRDIS=0 K ZTRTN,DIC,X2 D ^LRDPA Q:Y<0 D QUE G:POP END I $D(ZTSK) K ZTSK Q
U IO D LRLLOC,END Q
QUE S %ZIS="QM" D ^%ZIS Q:POP I $D(IO("Q")) K IO("Q") S:'$D(ZTRTN) ZTRTN="LRLLOC^LRACSUM" S ZTDESC="Patient lab summary" F I="%*","AGE","D*","LR*","PNM","SEX","SSN","U" S ZTSAVE(I)=""
I D ^%ZTLOAD S:'$D(ZTSK) POP=1 W !,"PRINT",$S('POP:"",1:" NOT")," QUEUED",! K ZTRTN,ZTIO,ZTDESC,ZTSAVE,LRBOT,LRNM,LRIDT,LROUT,LRDIS,LRCDT,LRTNN,LRDFN Q
Q
LRLLOC S:$D(ZTQUEUED) ZTREQ="@"
D SET S LRLLOC=$S($L(LRWRD):LRWRD,$D(^LR(LRDFN,.1)):^(.1),1:"File Room")
S SSN=" "_SSN_" "
S ^TMP($J,LRDFN,0)=PNM_U_SSN_U_AGE_U_LRDPF_U_DFN
S ^TMP($J,LRDFN,"MISC")="MISCELLANEOUS TESTS^" D LRIDT^LRACSUM1
D ^LRACSUM3,MICRO^LRACSUM1 Q
END D END^LRACM,^%ZISC
Q
SET S LRBOT=$P(^LAB(64.5,1,0),U,2),LRTD=$P(^(1,0),U,3),LRNM=0
K ^TMP($J),DIC D DT^LRX S LRCDT=LRDT0
D LRCALE^LRACSUM1 S LRTNN=2,LRDPF=+$P(^LR(LRDFN,0),U,2) D PT^LRX
Q
DIS U IO S LRFD=LRF-.5,LRLTR="FILE" D ^LRLTR F II=0:0 S LRFD=$O(^DGPM("AMV3",LRFD)) Q:LRFD<1!(LRFD>LRL) S LRFN=0 D FN ;MAS
Q
FN F JJ=0:0 S LRFN=$O(^DGPM("AMV3",LRFD,LRFN)) Q:LRFN<1 S LRINN=0 F K=0:0 S LRINN=$O(^DGPM("AMV3",LRFD,LRFN,LRINN)) Q:LRINN<1 D WORK ;MAS
Q
WORK Q:'$D(^DGPM(LRINN,0))!('$P(^(0),"^",14)) S X=^(0),LROUT=9999999-$P(^DGPM($P(X,"^",14),0),"^"),(LRIDT,LRIN)=9999999-$P(X,"^") ;MAS
Q:'$D(^DPT(LRFN,"LR")) S LRDFN=^("LR"),DFN=LRFN D PT^LRX D LRLLOC
Q
MANUAL S LREND=0,LRDIS=1 K DIC W !!,"Print Discharge Summaries for (1) Single patient -or- (2) All patients: 1// " R LRX:DTIME S:LRX="" LRX=1 Q:LRX["^" G:"12"'[LRX MANUAL
I LRX=1 D ^LRDPA Q:LRDFN<1 D LIST Q:X="^" D:'$D(LREDT) ^LRWU3 Q:LREND S (LRIDT,LRIN)=9999999-LRSDT,LROUT=9999999-LREDT
I $D(LRX),LRX=2 D ^LRWU3 Q:LREND S LRF=$P(LREDT,".",1),LRL=LRSDT K LREDT,LRSDT S ZTRTN="DIS^LRACSUM" D QUE K ZTRTN G:POP END G OUT
K LREDT,LRSDT D QUE G:POP END I $D(ZTSK) K ZTSK Q
U IO D LRLLOC,END
Q
DQ S LRDIS=1,X="T-1",%DT="" D ^%DT S LRF=+Y,LRL=+Y_.5
D DIS G END
LIST I '$D(^DGPM("C",DFN)) W !!,"No In-patient stays for this patient" Q ;MAS
S:'$D(IOM) IOM=80 W !!?10,"ADMISSION DATE",?35,"DISCHARGE DATE" D DASH^LRX
S L=0,LRI=0
F M=0:0 S L=$O(^DGPM("ATID1",DFN,L)) Q:L<1 D A ;MAS
W !!,"Select EPISODE OF CARE: None// " R X:DTIME K LREDT Q:X["^"!(X="") G:X="?" LIST Q:'$D(LRI(X)) S LREDT=$P($P(LRI(X),U,1),U,1),LRSDT=$P($P(LRI(X),U,2),U,1)_.5
Q
OUT I $D(ZTSK) K ZTSK Q
D DIS,END Q
A S Y="",X=$O(^DGPM("ATID1",DFN,L,0)) I X,$D(^DGPM(X,0)),$P(^(0),"^",2)=1 S Z=$P(^(0),"^",17),Y=9999999.9999999-L,LRI=LRI+1,LRI(LRI)=Y Q:'Y S Y=$$Y2K^LRX(Y) W !?4,LRI,". ",?10,Y
Q:'$G(Z) I $D(^DGPM(Z,0)) S Y=$P(^(0),"^"),LRI(LRI)=LRI(LRI)_U_Y S:Y Y=$$Y2K^LRX(Y) W ?35,Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRACSUM 2850 printed Oct 16, 2024@18:07:21 Page 2
LRACSUM ;SLC/DCM - INDIVIDUAL PATIENT SUMMARY. ;4/17/91 14:30 ;
+1 ;;5.2;LAB SERVICE;**27,201**;Sep 27, 1994
DFN SET LRIN=0
SET LRIDT=0
SET LREND=0
SET LROUT=9999999
SET LRDIS=0
KILL ZTRTN,DIC,X2
DO ^LRDPA
if Y<0
QUIT
DO QUE
if POP
GOTO END
IF $DATA(ZTSK)
KILL ZTSK
QUIT
+1 USE IO
DO LRLLOC
DO END
QUIT
QUE SET %ZIS="QM"
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
KILL IO("Q")
if '$DATA(ZTRTN)
SET ZTRTN="LRLLOC^LRACSUM"
SET ZTDESC="Patient lab summary"
FOR I="%*","AGE","D*","LR*","PNM","SEX","SSN","U"
SET ZTSAVE(I)=""
+1 IF $TEST
DO ^%ZTLOAD
if '$DATA(ZTSK)
SET POP=1
WRITE !,"PRINT",$SELECT('POP:"",1:" NOT")," QUEUED",!
KILL ZTRTN,ZTIO,ZTDESC,ZTSAVE,LRBOT,LRNM,LRIDT,LROUT,LRDIS,LRCDT,LRTNN,LRDFN
QUIT
+2 QUIT
LRLLOC if $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 DO SET
SET LRLLOC=$SELECT($LENGTH(LRWRD):LRWRD,$DATA(^LR(LRDFN,.1)):^(.1),1:"File Room")
+2 SET SSN=" "_SSN_" "
+3 SET ^TMP($JOB,LRDFN,0)=PNM_U_SSN_U_AGE_U_LRDPF_U_DFN
+4 SET ^TMP($JOB,LRDFN,"MISC")="MISCELLANEOUS TESTS^"
DO LRIDT^LRACSUM1
+5 DO ^LRACSUM3
DO MICRO^LRACSUM1
QUIT
END DO END^LRACM
DO ^%ZISC
+1 QUIT
SET SET LRBOT=$PIECE(^LAB(64.5,1,0),U,2)
SET LRTD=$PIECE(^(1,0),U,3)
SET LRNM=0
+1 KILL ^TMP($JOB),DIC
DO DT^LRX
SET LRCDT=LRDT0
+2 DO LRCALE^LRACSUM1
SET LRTNN=2
SET LRDPF=+$PIECE(^LR(LRDFN,0),U,2)
DO PT^LRX
+3 QUIT
DIS ;MAS
USE IO
SET LRFD=LRF-.5
SET LRLTR="FILE"
DO ^LRLTR
FOR II=0:0
SET LRFD=$ORDER(^DGPM("AMV3",LRFD))
if LRFD<1!(LRFD>LRL)
QUIT
SET LRFN=0
DO FN
+1 QUIT
FN ;MAS
FOR JJ=0:0
SET LRFN=$ORDER(^DGPM("AMV3",LRFD,LRFN))
if LRFN<1
QUIT
SET LRINN=0
FOR K=0:0
SET LRINN=$ORDER(^DGPM("AMV3",LRFD,LRFN,LRINN))
if LRINN<1
QUIT
DO WORK
+1 QUIT
WORK ;MAS
if '$DATA(^DGPM(LRINN,0))!('$PIECE(^(0),"^",14))
QUIT
SET X=^(0)
SET LROUT=9999999-$PIECE(^DGPM($PIECE(X,"^",14),0),"^")
SET (LRIDT,LRIN)=9999999-$PIECE(X,"^")
+1 if '$DATA(^DPT(LRFN,"LR"))
QUIT
SET LRDFN=^("LR")
SET DFN=LRFN
DO PT^LRX
DO LRLLOC
+2 QUIT
MANUAL SET LREND=0
SET LRDIS=1
KILL DIC
WRITE !!,"Print Discharge Summaries for (1) Single patient -or- (2) All patients: 1// "
READ LRX:DTIME
if LRX=""
SET LRX=1
if LRX["^"
QUIT
if "12"'[LRX
GOTO MANUAL
+1 IF LRX=1
DO ^LRDPA
if LRDFN<1
QUIT
DO LIST
if X="^"
QUIT
if '$DATA(LREDT)
DO ^LRWU3
if LREND
QUIT
SET (LRIDT,LRIN)=9999999-LRSDT
SET LROUT=9999999-LREDT
+2 IF $DATA(LRX)
IF LRX=2
DO ^LRWU3
if LREND
QUIT
SET LRF=$PIECE(LREDT,".",1)
SET LRL=LRSDT
KILL LREDT,LRSDT
SET ZTRTN="DIS^LRACSUM"
DO QUE
KILL ZTRTN
if POP
GOTO END
GOTO OUT
+3 KILL LREDT,LRSDT
DO QUE
if POP
GOTO END
IF $DATA(ZTSK)
KILL ZTSK
QUIT
+4 USE IO
DO LRLLOC
DO END
+5 QUIT
DQ SET LRDIS=1
SET X="T-1"
SET %DT=""
DO ^%DT
SET LRF=+Y
SET LRL=+Y_.5
+1 DO DIS
GOTO END
LIST ;MAS
IF '$DATA(^DGPM("C",DFN))
WRITE !!,"No In-patient stays for this patient"
QUIT
+1 if '$DATA(IOM)
SET IOM=80
WRITE !!?10,"ADMISSION DATE",?35,"DISCHARGE DATE"
DO DASH^LRX
+2 SET L=0
SET LRI=0
+3 ;MAS
FOR M=0:0
SET L=$ORDER(^DGPM("ATID1",DFN,L))
if L<1
QUIT
DO A
+4 WRITE !!,"Select EPISODE OF CARE: None// "
READ X:DTIME
KILL LREDT
if X["^"!(X="")
QUIT
if X="?"
GOTO LIST
if '$DATA(LRI(X))
QUIT
SET LREDT=$PIECE($PIECE(LRI(X),U,1),U,1)
SET LRSDT=$PIECE($PIECE(LRI(X),U,2),U,1)_.5
+5 QUIT
OUT IF $DATA(ZTSK)
KILL ZTSK
QUIT
+1 DO DIS
DO END
QUIT
A SET Y=""
SET X=$ORDER(^DGPM("ATID1",DFN,L,0))
IF X
IF $DATA(^DGPM(X,0))
IF $PIECE(^(0),"^",2)=1
SET Z=$PIECE(^(0),"^",17)
SET Y=9999999.9999999-L
SET LRI=LRI+1
SET LRI(LRI)=Y
if 'Y
QUIT
SET Y=$$Y2K^LRX(Y)
WRITE !?4,LRI,". ",?10,Y
+1 if '$GET(Z)
QUIT
IF $DATA(^DGPM(Z,0))
SET Y=$PIECE(^(0),"^")
SET LRI(LRI)=LRI(LRI)_U_Y
if Y
SET Y=$$Y2K^LRX(Y)
WRITE ?35,Y
+2 QUIT
