- LRACM2 ;SLC/DCM - MENU FOR CUMULATIVE REPORTS ;2/19/91 10:16
- ;;5.2;LAB SERVICE;**201,283**;Sep 27, 1994
- LRPG K ^LAC($J),DIC,X2 D ^LRDPA Q:LRDFN<0 S LRDPF=+$P(^LR(LRDFN,0),U,2) D PT^LRX S SSN=" "_SSN_" ",LRXLR=$J,^LAC(LRXLR,LRDFN,0)=LRDFN,LRRE=1,LRPERM=1
- W !!,"DISREGARD ANY PAGES THAT ARE PRINTED IN ADDITION TO THE ONE REQUESTED.",!
- LRPG1 R !!,"ENTER PAGE NUMBER TO BE REPRINTED (X:X): ",LRPG:DTIME G:"^."[LRPG END I LRPG'["MISC:" G:LRPG'?.N1P.N!(LRPG'[":") LRPG1
- D MISC G:'$D(^LR(LRDFN,"CH")) END K IO("Q") S %ZIS="Q" D ^%ZIS G:POP END
- I $D(IO("Q")) K IO("Q") S ZTRTN="DQ1^LRACM2" F I="AGE","DFN","DOB","LR*","PNM","SEX","SSN" S ZTSAVE(I)="",ZTDESC="CUMULATIVE REPORT"
- I D ^%ZTLOAD D ^%ZISC K ZTIO,ZTRTN,ZTSAVE,ZTSK,AGE,DFN,DOB,LRDFN,LRDPF,LRPG,LRRE,LRWRD,LRXLR,PNM,SEX,SSN G END
- DQ1 S:$D(ZTQUEUED) ZTREQ="@" U IO D LRPG2 I $O(^LAC(LRXLR,LRDFN,0))="MISC",$O(^("MISC",0))'>0 U IO(0) W $C(7),!!,"NO DATA FOUND WITH THIS PAGE NUMBER FOR THIS PATIENT!" D ^%ZISC K ^LAC(LRXLR) G END
- S LRLLOC=$S($L($G(LRWRD)):LRWRD,1:"File room"),X="T",%DT="" D ^%DT S LRDT=Y S Y=$$Y2K^LRX(Y) S LRCDT=Y
- S U="^",LRBOT=$P(^LAB(64.5,1,0),U,2)
- U IO S LRPG2=$P(LRPG,":",1),LRPG=$P(LRPG,":",2),LRPG1=1
- D LRCALE^LRAC2,ENT^LRAC3 K LRPG1
- K ^LAC($J) D END^LRACM D ^%ZISC Q
- LRPG2 S LRIDT=0 F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT<1 S LRTNN=1 D PG3
- Q
- PG3 Q:$P(^LR(LRDFN,"CH",LRIDT,0),U,9)'[LRPG S LRSUB=1 F S LRSUB=$O(^LR(LRDFN,"CH",LRIDT,LRSUB)) Q:LRSUB<1 D PG4
- Q
- PG4 Q:'$D(^LR(LRDFN,"CH",LRIDT,LRSUB)) S Z=^(0),LRIIDT=$P(Z,U,1),LRIPG=LRPG,LRVIDT=LRIIDT,LRSPM=$P(Z,U,5),LRTLOC=$E($P(Z,U,11),1,7),LRVDT=$P(Z,U,3),LRAN=$P(Z,U,6),(LX1,LX2)=0,LRTST=$O(^LAB(60,"C","CH;"_LRSUB_";1",0)) Q:LRTST<1
- D SUB2^LRAC2
- Q
- LPG ;from LRACM
- W !!?20,"This may take a while. LRPG X-REF INITILIZATION!",!
- S LRDFN=0 F S LRDFN=$O(^LR(LRDFN)) W "." Q:LRDFN<1 I $D(^LR(LRDFN,"PG")) W LRDFN K ^LR(LRDFN,"PG")
- Q
- EN ;
- LIST ;Call new patient list routine
- D ^LRACM2F Q
- ;LRACM2F REPLACES FOLLOWING CODE
- ;S %DT="AEQ",LRCTRR=0 D ^%DT Q:Y<1 S LRDT=Y S Y=$$Y2K^LRX(Y) S LRDT1=Y,%ZIS="Q" K IO("Q") D ^%ZIS Q:POP
- I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^LRACM2",ZTSAVE("LRCTRR")="",ZTSAVE("LRDT")="",ZTSAVE("LRDT1")="",ZTDESC="CUME REPORT" D ^%ZTLOAD D ^%ZISC K ZTRTN,ZTIO,ZTSAVE,ZTSK,LRCTRR,LRDT,LRDT1 Q
- DQ S:$D(ZTQUEUED) ZTREQ="@" U IO W @IOF,!!!!?60,LRDT1 D L W ! W:IO'=IO(0) @IOF D END^LRACM D ^%ZISC Q
- L S L="" F S L=$O(^LRO(69,LRDT,1,"AR",L)) Q:L="" W !!," LOCATION: ",L,?40,"LRDFN" D P
- Q
- P S P="" F S P=$O(^LRO(69,LRDT,1,"AR",L,P)) Q:P="" D Q
- Q
- Q S Q="" F S Q=$O(^LRO(69,LRDT,1,"AR",L,P,Q)) Q:Q="" S Y=^(Q),X=^LR(Q,0),LRDPF=$P(X,"^",2),DFN=$P(X,"^",3),LRCTRR=LRCTRR+1 D R
- Q
- MISC S ^LAC(LRXLR,LRDFN,"MISC",1,0)="MISCELLANEOUS TESTS" Q
- SUM W !!,"This report gets all lab data in the computer for a patient!",!
- S LRPRTPG=1,LRCUM=1
- D SUM^LRRP2
- D ^LRRK
- Q
- END D END^LRACM
- Q
- R D PT^LRX
- W !,LRCTRR,?6,$E(P,1,20),?27,$S(L'["FILE ROOM":SSN,1:$E($P(Y,U,2),1,20)),?40,$J(Q,5),?49,$S(+Y=1:"Processed",1:"")
- W ?61,"File: ",LRDPF,?70,$S($D(LRWRD):$E(LRWRD,1,9),1:"")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRACM2 3094 printed Feb 18, 2025@23:32:18 Page 2
- LRACM2 ;SLC/DCM - MENU FOR CUMULATIVE REPORTS ;2/19/91 10:16
- +1 ;;5.2;LAB SERVICE;**201,283**;Sep 27, 1994
- LRPG KILL ^LAC($JOB),DIC,X2
- DO ^LRDPA
- if LRDFN<0
- QUIT
- SET LRDPF=+$PIECE(^LR(LRDFN,0),U,2)
- DO PT^LRX
- SET SSN=" "_SSN_" "
- SET LRXLR=$JOB
- SET ^LAC(LRXLR,LRDFN,0)=LRDFN
- SET LRRE=1
- SET LRPERM=1
- +1 WRITE !!,"DISREGARD ANY PAGES THAT ARE PRINTED IN ADDITION TO THE ONE REQUESTED.",!
- LRPG1 READ !!,"ENTER PAGE NUMBER TO BE REPRINTED (X:X): ",LRPG:DTIME
- if "^."[LRPG
- GOTO END
- IF LRPG'["MISC:"
- if LRPG'?.N1P.N!(LRPG'["
- GOTO LRPG1
- +1 DO MISC
- if '$DATA(^LR(LRDFN,"CH"))
- GOTO END
- KILL IO("Q")
- SET %ZIS="Q"
- DO ^%ZIS
- if POP
- GOTO END
- +2 IF $DATA(IO("Q"))
- KILL IO("Q")
- SET ZTRTN="DQ1^LRACM2"
- FOR I="AGE","DFN","DOB","LR*","PNM","SEX","SSN"
- SET ZTSAVE(I)=""
- SET ZTDESC="CUMULATIVE REPORT"
- +3 IF $TEST
- DO ^%ZTLOAD
- DO ^%ZISC
- KILL ZTIO,ZTRTN,ZTSAVE,ZTSK,AGE,DFN,DOB,LRDFN,LRDPF,LRPG,LRRE,LRWRD,LRXLR,PNM,SEX,SSN
- GOTO END
- DQ1 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- USE IO
- DO LRPG2
- IF $ORDER(^LAC(LRXLR,LRDFN,0))="MISC"
- IF $ORDER(^("MISC",0))'>0
- USE IO(0)
- WRITE $CHAR(7),!!,"NO DATA FOUND WITH THIS PAGE NUMBER FOR THIS PATIENT!"
- DO ^%ZISC
- KILL ^LAC(LRXLR)
- GOTO END
- +1 SET LRLLOC=$SELECT($LENGTH($GET(LRWRD)):LRWRD,1:"File room")
- SET X="T"
- SET %DT=""
- DO ^%DT
- SET LRDT=Y
- SET Y=$$Y2K^LRX(Y)
- SET LRCDT=Y
- +2 SET U="^"
- SET LRBOT=$PIECE(^LAB(64.5,1,0),U,2)
- +3 USE IO
- SET LRPG2=$PIECE(LRPG,":",1)
- SET LRPG=$PIECE(LRPG,":",2)
- SET LRPG1=1
- +4 DO LRCALE^LRAC2
- DO ENT^LRAC3
- KILL LRPG1
- +5 KILL ^LAC($JOB)
- DO END^LRACM
- DO ^%ZISC
- QUIT
- LRPG2 SET LRIDT=0
- FOR
- SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
- if LRIDT<1
- QUIT
- SET LRTNN=1
- DO PG3
- +1 QUIT
- PG3 if $PIECE(^LR(LRDFN,"CH",LRIDT,0),U,9)'[LRPG
- QUIT
- SET LRSUB=1
- FOR
- SET LRSUB=$ORDER(^LR(LRDFN,"CH",LRIDT,LRSUB))
- if LRSUB<1
- QUIT
- DO PG4
- +1 QUIT
- PG4 if '$DATA(^LR(LRDFN,"CH",LRIDT,LRSUB))
- QUIT
- SET Z=^(0)
- SET LRIIDT=$PIECE(Z,U,1)
- SET LRIPG=LRPG
- SET LRVIDT=LRIIDT
- SET LRSPM=$PIECE(Z,U,5)
- SET LRTLOC=$EXTRACT($PIECE(Z,U,11),1,7)
- SET LRVDT=$PIECE(Z,U,3)
- SET LRAN=$PIECE(Z,U,6)
- SET (LX1,LX2)=0
- SET LRTST=$ORDER(^LAB(60,"C","CH;"_LRSUB_";1",0))
- if LRTST<1
- QUIT
- +1 DO SUB2^LRAC2
- +2 QUIT
- LPG ;from LRACM
- +1 WRITE !!?20,"This may take a while. LRPG X-REF INITILIZATION!",!
- +2 SET LRDFN=0
- FOR
- SET LRDFN=$ORDER(^LR(LRDFN))
- WRITE "."
- if LRDFN<1
- QUIT
- IF $DATA(^LR(LRDFN,"PG"))
- WRITE LRDFN
- KILL ^LR(LRDFN,"PG")
- +3 QUIT
- EN ;
- LIST ;Call new patient list routine
- +1 DO ^LRACM2F
- QUIT
- +2 ;LRACM2F REPLACES FOLLOWING CODE
- +3 ;S %DT="AEQ",LRCTRR=0 D ^%DT Q:Y<1 S LRDT=Y S Y=$$Y2K^LRX(Y) S LRDT1=Y,%ZIS="Q" K IO("Q") D ^%ZIS Q:POP
- +4 IF $DATA(IO("Q"))
- KILL IO("Q")
- SET ZTRTN="DQ^LRACM2"
- SET ZTSAVE("LRCTRR")=""
- SET ZTSAVE("LRDT")=""
- SET ZTSAVE("LRDT1")=""
- SET ZTDESC="CUME REPORT"
- DO ^%ZTLOAD
- DO ^%ZISC
- KILL ZTRTN,ZTIO,ZTSAVE,ZTSK,LRCTRR,LRDT,LRDT1
- QUIT
- DQ if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- USE IO
- WRITE @IOF,!!!!?60,LRDT1
- DO L
- WRITE !
- if IO'=IO(0)
- WRITE @IOF
- DO END^LRACM
- DO ^%ZISC
- QUIT
- L SET L=""
- FOR
- SET L=$ORDER(^LRO(69,LRDT,1,"AR",L))
- if L=""
- QUIT
- WRITE !!," LOCATION: ",L,?40,"LRDFN"
- DO P
- +1 QUIT
- P SET P=""
- FOR
- SET P=$ORDER(^LRO(69,LRDT,1,"AR",L,P))
- if P=""
- QUIT
- DO Q
- +1 QUIT
- Q SET Q=""
- FOR
- SET Q=$ORDER(^LRO(69,LRDT,1,"AR",L,P,Q))
- if Q=""
- QUIT
- SET Y=^(Q)
- SET X=^LR(Q,0)
- SET LRDPF=$PIECE(X,"^",2)
- SET DFN=$PIECE(X,"^",3)
- SET LRCTRR=LRCTRR+1
- DO R
- +1 QUIT
- MISC SET ^LAC(LRXLR,LRDFN,"MISC",1,0)="MISCELLANEOUS TESTS"
- QUIT
- SUM WRITE !!,"This report gets all lab data in the computer for a patient!",!
- +1 SET LRPRTPG=1
- SET LRCUM=1
- +2 DO SUM^LRRP2
- +3 DO ^LRRK
- +4 QUIT
- END DO END^LRACM
- +1 QUIT
- R DO PT^LRX
- +1 WRITE !,LRCTRR,?6,$EXTRACT(P,1,20),?27,$SELECT(L'["FILE ROOM":SSN,1:$EXTRACT($PIECE(Y,U,2),1,20)),?40,$JUSTIFY(Q,5),?49,$SELECT(+Y=1:"Processed",1:"")
- +2 WRITE ?61,"File: ",LRDPF,?70,$SELECT($DATA(LRWRD):$EXTRACT(LRWRD,1,9),1:"")
- +3 QUIT