- 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 Mar 13, 2025@21:24:52 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
