LRSMAC ;SLC/RWF - CHEM. LAB SMAC REPORT ;2/19/91 13:08 ;
;;5.2;LAB SERVICE;**201**;Sep 27, 1994
PR1 S LRRN=1 G PR ;ASTRA
PR2 S LRRN=2 G PR ;SMAC
LH F I=173:1:193 S:$D(^LAB(60,I,1,LRSERUM,0)) Z=^(0),L(I-172)=$P(Z,U,3),H(I-172)=$P(Z,U,4)
Q
ZLH I LRZZ,LRZZ<L(K)!(LRZZ>H(K)) W $E("LH",LRZZ>H(K)+1)
Q
PR Q:(LRDFN=-1) K LRIDT,LRSV S LRIDT=0,%DT="",LRNL=""
IF '$D(^LR(LRDFN,"CH")) W !!,"NO DATA" K LRDFN Q
K %ZIS D ^%ZIS Q:POP S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX U IO W @IOF
PALL K LRIDT,LRSV S LRIDT=0,%DT="",LRNL=""
S U="^",LREND=0,J=0 D HEAD,LH
S LRPQ="^22^16^9^27^32^37^42^47^9^15^21^27^34^42^48^54^59^63^68^73"
S LRXW="IF $L(LRZZ) W ?$P(LRPQ,U,I),$S(""<>""[$E(LRZZ):$J(LRZZ,4),LRZZ#1:$J(LRZZ,4,1)_$P(LRZZ,+LRZZ,2),1:$J(+LRZZ,4))"
PRL D:$Y+4>(IOSL\LRRN) PRL2,WAIT,HEAD:'LREND G K:LREND S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) G LREND:LRIDT<1
S Z0=^LR(LRDFN,"CH",LRIDT,0) G PRL:'$P(Z0,U,3)
K LREM S LREM=0 F S LREM=$O(^LR(LRDFN,"CH",LRIDT,1,LREM)) Q:LREM<1 S LREM(LREM)=^(LREM,0)
S L=0 F Z=2:1:21 S Z(Z)=$S($D(^LR(LRDFN,"CH",LRIDT,Z)):$P(^(Z),U,1),1:""),L=L+$L(Z(Z))
G:L=0 PRL
D DAT W:DT-$E(Z0,1,7)>300 !,1700+$E(Z0,1,3) W !,Y,?6,LRSPEC
F I=4,3,2,5:1:9 S LRZZ=Z(I) X LRXW
W ?57,T,?64,$P(Z0,U,8),?71,$P(Z0,U,6)
D PRL4 S:LRRN=2 LRSV($Y)=LRIDT G PRL
PRL2 Q:'$D(LRSV) Q:$O(LRSV(0))<1 D H3
S LRSV=0 F S LRSV=$O(LRSV(LRSV)) Q:LRSV<1 S Z0=^LR(LRDFN,"CH",LRSV(LRSV),0) D PRL3
K LRSV Q
PRL3 D DAT W:DT-$E(Z0,1,7)>300 !,1700+$E(Z0,1,3) W !,Y,?6,LRSPEC
S L=0 F I=10:1:21 S Z(I)=$S($D(^LR(LRDFN,"CH",LRSV(LRSV),I)):^(I),1:""),L=L+$L(Z(I))
Q:L=0 F I=10:1:21 S LRZZ=Z(I) X LRXW
K LREM S LREM=0 F S LREM=$O(^LR(LRDFN,"CH",LRIDT,1,LREM)) Q:LREM<1 S LREM(LREM)=^(LREM,0)
PRL4 S LREM=0 F S LREM=$O(LREM(LREM)) Q:LREM<1 W:$L(LREM(LREM))>0 !,"NOTE: ",LREM(LREM)
W:$O(LREM(0)) ! Q
HEAD W @IOF S LRLDT=0
S X=$H X ^%ZOSF("ZD") W $$INS^LRU," CHEMISTRY REPORT ",Y," ",SSN," ",PNM,?72,"AGE ",AGE
H2 W !,"DATE S/U",?9,"CREAT UREA GLU NA K CL CO2 CA TIME METH LOG"
Q
H3 S LRDX=0,LRDY=10 ;X XY
W !?5,"S/U PO4 URIC CHOLEST T-PROT ALBUMIN T-BIL D-BIL AKL0 LDH SGOT SGPT GGPT" Q
DAT S X=+Z0,Y=$$FMTE^XLFDT(X,"5Z"),T=$P(Y,"@",2),Y=$P(Y,"@")
S T=T_$S($P(Z0,U,2):"r",1:"D"),LRSPEC=$P(Z0,U,5),LRSPEC=$S(LRSPEC=LRSERUM:"S",LRSPEC=LRURINE:"U",1:" ")
Q
;
WAIT R !!,"PRESS '^' TO STOP ",J:DTIME U IO S:J="" J=1 S LREND=".^"[J Q
LREND D PRL2 W !," last data " D:$D(LRIDT) WAIT
K D ^%ZISC K LRIDT,LRRN,LRPQ,LRDY,LRXW,Z,L,H Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSMAC 2505 printed Dec 13, 2024@02:20:22 Page 2
LRSMAC ;SLC/RWF - CHEM. LAB SMAC REPORT ;2/19/91 13:08 ;
+1 ;;5.2;LAB SERVICE;**201**;Sep 27, 1994
PR1 ;ASTRA
SET LRRN=1
GOTO PR
PR2 ;SMAC
SET LRRN=2
GOTO PR
LH FOR I=173:1:193
if $DATA(^LAB(60,I,1,LRSERUM,0))
SET Z=^(0)
SET L(I-172)=$PIECE(Z,U,3)
SET H(I-172)=$PIECE(Z,U,4)
+1 QUIT
ZLH IF LRZZ
IF LRZZ<L(K)!(LRZZ>H(K))
WRITE $EXTRACT("LH",LRZZ>H(K)+1)
+1 QUIT
PR if (LRDFN=-1)
QUIT
KILL LRIDT,LRSV
SET LRIDT=0
SET %DT=""
SET LRNL=""
+1 IF '$DATA(^LR(LRDFN,"CH"))
WRITE !!,"NO DATA"
KILL LRDFN
QUIT
+2 KILL %ZIS
DO ^%ZIS
if POP
QUIT
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO PT^LRX
USE IO
WRITE @IOF
PALL KILL LRIDT,LRSV
SET LRIDT=0
SET %DT=""
SET LRNL=""
+1 SET U="^"
SET LREND=0
SET J=0
DO HEAD
DO LH
+2 SET LRPQ="^22^16^9^27^32^37^42^47^9^15^21^27^34^42^48^54^59^63^68^73"
+3 SET LRXW="IF $L(LRZZ) W ?$P(LRPQ,U,I),$S(""<>""[$E(LRZZ):$J(LRZZ,4),LRZZ#1:$J(LRZZ,4,1)_$P(LRZZ,+LRZZ,2),1:$J(+LRZZ,4))"
PRL if $Y+4>(IOSL\LRRN)
DO PRL2
DO WAIT
if 'LREND
DO HEAD
if LREND
GOTO K
SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
if LRIDT<1
GOTO LREND
+1 SET Z0=^LR(LRDFN,"CH",LRIDT,0)
if '$PIECE(Z0,U,3)
GOTO PRL
+2 KILL LREM
SET LREM=0
FOR
SET LREM=$ORDER(^LR(LRDFN,"CH",LRIDT,1,LREM))
if LREM<1
QUIT
SET LREM(LREM)=^(LREM,0)
+3 SET L=0
FOR Z=2:1:21
SET Z(Z)=$SELECT($DATA(^LR(LRDFN,"CH",LRIDT,Z)):$PIECE(^(Z),U,1),1:"")
SET L=L+$LENGTH(Z(Z))
+4 if L=0
GOTO PRL
+5 DO DAT
if DT-$EXTRACT(Z0,1,7)>300
WRITE !,1700+$EXTRACT(Z0,1,3)
WRITE !,Y,?6,LRSPEC
+6 FOR I=4,3,2,5:1:9
SET LRZZ=Z(I)
XECUTE LRXW
+7 WRITE ?57,T,?64,$PIECE(Z0,U,8),?71,$PIECE(Z0,U,6)
+8 DO PRL4
if LRRN=2
SET LRSV($Y)=LRIDT
GOTO PRL
PRL2 if '$DATA(LRSV)
QUIT
if $ORDER(LRSV(0))<1
QUIT
DO H3
+1 SET LRSV=0
FOR
SET LRSV=$ORDER(LRSV(LRSV))
if LRSV<1
QUIT
SET Z0=^LR(LRDFN,"CH",LRSV(LRSV),0)
DO PRL3
+2 KILL LRSV
QUIT
PRL3 DO DAT
if DT-$EXTRACT(Z0,1,7)>300
WRITE !,1700+$EXTRACT(Z0,1,3)
WRITE !,Y,?6,LRSPEC
+1 SET L=0
FOR I=10:1:21
SET Z(I)=$SELECT($DATA(^LR(LRDFN,"CH",LRSV(LRSV),I)):^(I),1:"")
SET L=L+$LENGTH(Z(I))
+2 if L=0
QUIT
FOR I=10:1:21
SET LRZZ=Z(I)
XECUTE LRXW
+3 KILL LREM
SET LREM=0
FOR
SET LREM=$ORDER(^LR(LRDFN,"CH",LRIDT,1,LREM))
if LREM<1
QUIT
SET LREM(LREM)=^(LREM,0)
PRL4 SET LREM=0
FOR
SET LREM=$ORDER(LREM(LREM))
if LREM<1
QUIT
if $LENGTH(LREM(LREM))>0
WRITE !,"NOTE: ",LREM(LREM)
+1 if $ORDER(LREM(0))
WRITE !
QUIT
HEAD WRITE @IOF
SET LRLDT=0
+1 SET X=$HOROLOG
XECUTE ^%ZOSF("ZD")
WRITE $$INS^LRU," CHEMISTRY REPORT ",Y," ",SSN," ",PNM,?72,"AGE ",AGE
H2 WRITE !,"DATE S/U",?9,"CREAT UREA GLU NA K CL CO2 CA TIME METH LOG"
+1 QUIT
H3 ;X XY
SET LRDX=0
SET LRDY=10
+1 WRITE !?5,"S/U PO4 URIC CHOLEST T-PROT ALBUMIN T-BIL D-BIL AKL0 LDH SGOT SGPT GGPT"
QUIT
DAT SET X=+Z0
SET Y=$$FMTE^XLFDT(X,"5Z")
SET T=$PIECE(Y,"@",2)
SET Y=$PIECE(Y,"@")
+1 SET T=T_$SELECT($PIECE(Z0,U,2):"r",1:"D")
SET LRSPEC=$PIECE(Z0,U,5)
SET LRSPEC=$SELECT(LRSPEC=LRSERUM:"S",LRSPEC=LRURINE:"U",1:" ")
+2 QUIT
+3 ;
WAIT READ !!,"PRESS '^' TO STOP ",J:DTIME
USE IO
if J=""
SET J=1
SET LREND=".^"[J
QUIT
LREND DO PRL2
WRITE !," last data "
if $DATA(LRIDT)
DO WAIT
K DO ^%ZISC
KILL LRIDT,LRRN,LRPQ,LRDY,LRXW,Z,L,H
QUIT
