- LRACSUM ; IHS/DIR/AAB - INDIVIDUAL PATIENT SUMMARY. 4/17/91 14:30 ; [ 07/08/1998 3:17 PM ]
- ;;5.2;LR;**1006**;SEP 01, 1998
- ;
- ;;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)=""
- 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="%*","DOB","D*","LR*","PNM","SEX","SSN","HRCN","U" S ZTSAVE(I)="" ;IHS/ANMC/CLS 11/1/95
- 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,HRCN Q ;IHS/ANMC/CLS 11/1/95
- 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 HRCN=" "_HRCN_" " ;IHS/ANMC/CLS 11/1/95
- ;S ^TMP($J,LRDFN,0)=PNM_U_SSN_U_AGE_U_LRDPF_U_DFN
- S ^TMP($J,LRDFN,0)=PNM_U_HRCN_U_DOB_U_LRDPF_U_DFN ;IHS/ANMC/CLS 11/1/95
- 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
- LRACSUM ; IHS/DIR/AAB - INDIVIDUAL PATIENT SUMMARY. 4/17/91 14:30 ; [ 07/08/1998 3:17 PM ]
- +1 ;;5.2;LR;**1006**;SEP 01, 1998
- +2 ;
- +3 ;;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 ;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)=""
- +1 ;IHS/ANMC/CLS 11/1/95
- 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="%*","DOB","D*","LR*","PNM","SEX","SSN","HRCN","U"
- SET ZTSAVE(I)=""
- +2 ;IHS/ANMC/CLS 11/1/95
- 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,HRCN
- QUIT
- +3 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 ;S SSN=" "_SSN_" "
- +3 ;IHS/ANMC/CLS 11/1/95
- SET HRCN=" "_HRCN_" "
- +4 ;S ^TMP($J,LRDFN,0)=PNM_U_SSN_U_AGE_U_LRDPF_U_DFN
- +5 ;IHS/ANMC/CLS 11/1/95
- SET ^TMP($JOB,LRDFN,0)=PNM_U_HRCN_U_DOB_U_LRDPF_U_DFN
- +6 SET ^TMP($JOB,LRDFN,"MISC")="MISCELLANEOUS TESTS^"
- DO LRIDT^LRACSUM1
- +7 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
