LRDIQ ;DALOI/FHS - MODIFIED LAB VERSION OF CAPTIONED TEMPLATE FILEMAN 19 ;04/19/16 15:56
;;5.2;LAB SERVICE;**86,153,263,290,458**;Sep 27, 1994;Build 10
Q
;
;
EN ; From LRLIST,LRLISTPS,LROE1,LRSOR
S:'$G(S) S=1
I $G(DX(0))="" N DX D
. S DX(0)="Q"
. I $D(IOST)#2,IOST?1"C".E S DX(0)="S S=$Y I S>22 N X,Y S DIR(0)=""E"" D ^DIR K DIR W @IOF S S=$S($D(DIRUT):0,1:1)"
. I $D(IOST)#2,IOST?1"P".E S DX(0)="S S=$G(S)+1 I S>(IOSL-6) W @IOF S S=1"
S ^UTILITY($J,1)=DX(0)
I $X W !
; If file #63 "CH" subscript then special handling
I $G(LRLONG),DIC["""CH""",$P(DR,":",2)>1 D Q
. N LRDFN,LRDR,LRSB,LRX
. S LRDR=DR,DR=$P(LRDR,":")_":1"
. D EN^DIQ Q:$G(DIRUT)
. I $X W !
. S LRSB=1,LRX=$P($P(DIC,","),"(",2) S:LRX'=+LRX LRX=@LRX
. F S LRSB=$O(^LR(LRX,"CH",DA,LRSB)) Q:'LRSB D DSP Q:$G(DIRUT)
. K ^UTILITY($J,1)
;
; Otherwise all others use normal FileMan DIQ call
D EN^DIQ
K ^UTILITY($J,1)
Q
;
;
DSP ; Display FileMan fields and
; non FileMan fields only shown with LRVERIFY key on certain supervisor reports
;
N LRQX,LRW,LRWL,LRY,LRZ,X,Y,ZZ
S LRY=$$TSTRES^LRRPU(LRX,"CH",DA,LRSB,"",1)
S ZZ(0)=$$GET1^DID(63.04,LRSB,"","LABEL")_": "_$TR($P(LRY,"^",1,2),"^"," ")
I $P($G(LRLABKY),U,2) D
. ; set Result[DUZ/Institution/LOINC code/EEI]
. S LRZ=^LR(LRX,"CH",DA,LRSB)
. I $P(LRY,"^",9) S ZZ(1)="PERFORMED/RELEASED BY: "_$$NAME^XUSER($P(LRY,"^",9),"F")
. I $P(LRZ,"^",6) S ZZ(1.1)="PERFORMED/RELEASED ON: "_$$FMTE^XLFDT($P(LRZ,U,6),"1Z")
. I $P(LRY,"^",6) S ZZ(2)="PERFORMING LAB: "_$P($$NS^XUAF4($P(LRY,"^",6)),"^")
. S X=$P(LRY,"^",8)
. I $P(X,"!",3)'="" S ZZ(3)="LOINC Code: "_$P($P(X,"!",3),";")
. I $P(LRY,U,10)'="" S ZZ(4)="EII: "_$P(LRY,U,10)
. I $G(LRLONG)=1 Q
. ; set low/high/units
. S ZZ(0)=ZZ(0)_" ("_$P(LRY,"^",3)_$S($P(LRY,"^",4)'="":"-"_$P(LRY,"^",4),1:"")_" "_$P(LRY,"^",5)_")"
;
S LRW=""
F S LRW=$O(ZZ(LRW)) Q:LRW="" D Q:$G(DIRUT)
. I LRW=0,$O(ZZ(LRW)) W !
. D I ($L(ZZ(LRW))+LRQX)>IOM Q:$$STOP D
. . S LRQX=$S($X:$X+1\40+1*40,1:2)
. . I LRQX=2,LRW>0 S LRQX=3
. W ?LRQX
. F S LRWL=IOM-$X D Q:ZZ(LRW)="" Q:$$STOP
. . W $E(ZZ(LRW),1,LRWL)
. . S ZZ(LRW)=$E(ZZ(LRW),LRWL+1,999)
Q
;
;
STOP() ;
I $X W !
X DX(0)
Q '$G(S)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRDIQ 2249 printed Sep 23, 2025@19:49:35 Page 2
LRDIQ ;DALOI/FHS - MODIFIED LAB VERSION OF CAPTIONED TEMPLATE FILEMAN 19 ;04/19/16 15:56
+1 ;;5.2;LAB SERVICE;**86,153,263,290,458**;Sep 27, 1994;Build 10
+2 QUIT
+3 ;
+4 ;
EN ; From LRLIST,LRLISTPS,LROE1,LRSOR
+1 if '$GET(S)
SET S=1
+2 IF $GET(DX(0))=""
NEW DX
Begin DoDot:1
+3 SET DX(0)="Q"
+4 IF $DATA(IOST)#2
IF IOST?1"C".E
SET DX(0)="S S=$Y I S>22 N X,Y S DIR(0)=""E"" D ^DIR K DIR W @IOF S S=$S($D(DIRUT):0,1:1)"
+5 IF $DATA(IOST)#2
IF IOST?1"P".E
SET DX(0)="S S=$G(S)+1 I S>(IOSL-6) W @IOF S S=1"
End DoDot:1
+6 SET ^UTILITY($JOB,1)=DX(0)
+7 IF $X
WRITE !
+8 ; If file #63 "CH" subscript then special handling
+9 IF $GET(LRLONG)
IF DIC["""CH"""
IF $PIECE(DR,":",2)>1
Begin DoDot:1
+10 NEW LRDFN,LRDR,LRSB,LRX
+11 SET LRDR=DR
SET DR=$PIECE(LRDR,":")_":1"
+12 DO EN^DIQ
if $GET(DIRUT)
QUIT
+13 IF $X
WRITE !
+14 SET LRSB=1
SET LRX=$PIECE($PIECE(DIC,","),"(",2)
if LRX'=+LRX
SET LRX=@LRX
+15 FOR
SET LRSB=$ORDER(^LR(LRX,"CH",DA,LRSB))
if 'LRSB
QUIT
DO DSP
if $GET(DIRUT)
QUIT
+16 KILL ^UTILITY($JOB,1)
End DoDot:1
QUIT
+17 ;
+18 ; Otherwise all others use normal FileMan DIQ call
+19 DO EN^DIQ
+20 KILL ^UTILITY($JOB,1)
+21 QUIT
+22 ;
+23 ;
DSP ; Display FileMan fields and
+1 ; non FileMan fields only shown with LRVERIFY key on certain supervisor reports
+2 ;
+3 NEW LRQX,LRW,LRWL,LRY,LRZ,X,Y,ZZ
+4 SET LRY=$$TSTRES^LRRPU(LRX,"CH",DA,LRSB,"",1)
+5 SET ZZ(0)=$$GET1^DID(63.04,LRSB,"","LABEL")_": "_$TRANSLATE($PIECE(LRY,"^",1,2),"^"," ")
+6 IF $PIECE($GET(LRLABKY),U,2)
Begin DoDot:1
+7 ; set Result[DUZ/Institution/LOINC code/EEI]
+8 SET LRZ=^LR(LRX,"CH",DA,LRSB)
+9 IF $PIECE(LRY,"^",9)
SET ZZ(1)="PERFORMED/RELEASED BY: "_$$NAME^XUSER($PIECE(LRY,"^",9),"F")
+10 IF $PIECE(LRZ,"^",6)
SET ZZ(1.1)="PERFORMED/RELEASED ON: "_$$FMTE^XLFDT($PIECE(LRZ,U,6),"1Z")
+11 IF $PIECE(LRY,"^",6)
SET ZZ(2)="PERFORMING LAB: "_$PIECE($$NS^XUAF4($PIECE(LRY,"^",6)),"^")
+12 SET X=$PIECE(LRY,"^",8)
+13 IF $PIECE(X,"!",3)'=""
SET ZZ(3)="LOINC Code: "_$PIECE($PIECE(X,"!",3),";")
+14 IF $PIECE(LRY,U,10)'=""
SET ZZ(4)="EII: "_$PIECE(LRY,U,10)
+15 IF $GET(LRLONG)=1
QUIT
+16 ; set low/high/units
+17 SET ZZ(0)=ZZ(0)_" ("_$PIECE(LRY,"^",3)_$SELECT($PIECE(LRY,"^",4)'="":"-"_$PIECE(LRY,"^",4),1:"")_" "_$PIECE(LRY,"^",5)_")"
End DoDot:1
+18 ;
+19 SET LRW=""
+20 FOR
SET LRW=$ORDER(ZZ(LRW))
if LRW=""
QUIT
Begin DoDot:1
+21 IF LRW=0
IF $ORDER(ZZ(LRW))
WRITE !
+22 Begin DoDot:2
+23 SET LRQX=$SELECT($X:$X+1\40+1*40,1:2)
+24 IF LRQX=2
IF LRW>0
SET LRQX=3
End DoDot:2
IF ($LENGTH(ZZ(LRW))+LRQX)>IOM
if $$STOP
QUIT
Begin DoDot:2
End DoDot:2
+25 WRITE ?LRQX
+26 FOR
SET LRWL=IOM-$X
Begin DoDot:2
+27 WRITE $EXTRACT(ZZ(LRW),1,LRWL)
+28 SET ZZ(LRW)=$EXTRACT(ZZ(LRW),LRWL+1,999)
End DoDot:2
if ZZ(LRW)=""
QUIT
if $$STOP
QUIT
End DoDot:1
if $GET(DIRUT)
QUIT
+29 QUIT
+30 ;
+31 ;
STOP() ;
+1 IF $X
WRITE !
+2 XECUTE DX(0)
+3 QUIT '$GET(S)
