- 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 Jan 18, 2025@03:14:38 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)