LRVERA ;DALOI/JMC - READ ACCESSION/UID ;06/01/10 11:50
;;5.2;LAB SERVICE;**153,271,286,350**;Sep 27, 1994;Build 230
;
; ZEXCEPT is used to identify variables which are external to a specific TAG
; used in conjunction with Eclipse M-editor.
;
ACC ; Prompt for accession selection
D EN^LRWU4
Q
;
;
UID ; Prompt for UID selection
;
;ZEXCEPT: LRAA,LRAD,LRAN,LRUID
;
N LRQUIT,LRX,LRY
;
W !
S (LRQUIT,LRY)=0
F D Q:LRQUIT
. S LRX=$$UID^LRWU4("Unique Identifier",$G(LRUID))
. I LRX=0 S LRUID="",(LRAA,LRAD,LRAN)=-1,LRQUIT=1 Q
. S LRY=$$CHECKUID^LRWU4(LRX,"")
. I LRY S LRQUIT=1 Q
. W !,"No accession on file for this UID."
. S LRUID=""
;
; If good UID then update variables if user selected a different UID
; Display accession.
I LRY D
. I $G(LRUID)'=LRX S LRUID=LRX,LRAA=$P(LRY,"^",2),LRAD=$P(LRY,"^",3),LRAN=$P(LRY,"^",4)
. W " (",$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^"),")"
Q
;
;
SELPL(LR4,LRFLAG) ; Select the performing laboratory to store with test results.
; Call with LR4 = default institution, usually value of DUZ(2)
; LRFLAG = 0 (host lab only) / 1 (allow selection of collecting or host lab)
;
; Returns LR4 = ien of file #4 institution selected
;
N DIC,DTOUT,DUOUT,X,Y
S DIC="^DIC(4,",DIC(0)="AEMOQ",LRFLAG=+$G(LRFLAG)
S DIC("A")="Select Performing Laboratory: "
I $G(LR4)>0 S DIC("B")=$$GET1^DIQ(4,LR4_",",.01)
S DIC("S")="I $$SCRNPL^LRVERA(LRFLAG)"
D ^DIC
I Y<1 S LR4=0
E S LR4=$P(Y,"^")
;
Q LR4
;
;
SCRNPL(LRFLAG) ; Screen performing laboratory
; Called by DIC("S") lookup above when selecting performing laboratory
; Call with LRFLAG = allow selection of collecting or host lab
;
;ZEXCEPT: Y
;
N OK
S OK=0
I Y=DUZ(2) S OK=1
I 'OK D
. I $D(^LAHM(62.9,"CH",DUZ(2),Y)) S OK=1 Q
. I LRFLAG,$D(^LAHM(62.9,"CH",Y,DUZ(2))) S OK=1
;
Q OK
;
;
PLOK(LRX,LRY,LRZ,LR60) ; Check if user is editing results that appear to have
; been performed by a lab different from the one they selected and.
; ask if changing performing lab is ok.
;
; Call with LRX = file #4 ien of performing lab on record
; LRY = file #4 ien of performing lab user selected
; LRZ = user's current division - DUZ(2)
; LR60 = file #60 ien of test selected
;
; Returns 1=YES, 0=NO
;
N DIR,DIRUT,DTOUT,DUOUT,OK,X,Y
S OK=1
I LRX D
. I LRY,LRX=LRY Q
. I LRX=LRZ Q
. S DIR("A",1)="The performing lab recorded for test "_$$GET1^DIQ(60,LR60_",",.01)_" is: "_$$GET1^DIQ(4,LRX_",",.01)
. S DIR("A",2)="You indicated the performing lab is: "_$$GET1^DIQ(4,$S(LRY:LRY,1:LRZ)_",",.01)
. S DIR("A")="Do you want to continue",DIR("B")="NO"
. S DIR(0)="YO",OK=0
. W ! D ^DIR
. I Y=1 S OK=1
Q OK
;
;
SETRL(LRDFN,LRSS,LRIDT,LR4) ; Set reporting laboratory for entry in file #63
; Call with LRDFN = File #63 IEN
; LRSS = file #63 subscript
; LRIDT = inverse date/time of specimen ("AU" should pass 0)
; LR4 = file #4 IEN to store as reporting laboratory
;
N FDA,LRDIE,LRFILE
;
I LRSS'="AU",(LRDFN*LRIDT*LR4)<1 Q
I LRSS'="AU",LR4=+$G(^LR(LRDFN,LRSS,LRIDT,"RF")) Q
I LRSS="AU",LR4=$P($G(^LR(LRDFN,"AU")),"^",18) Q
;
S LRFILE=$S(LRSS="CH":63.04,LRSS="MI":63.05,LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,LRSS="AU":63,1:0)
I LRFILE<1 Q
;
I LRSS'="AU" S FDA(1,LRFILE,LRIDT_","_LRDFN_",",.345)=LR4
E S FDA(1,LRFILE,LRDFN_",",14.91)=LR4
D FILE^DIE("","FDA(1)","LRDIE(1)")
;
Q
;
;
RFLAG(FLAG) ; Ask user for referral high/low/critical flag in case they
; don't have values to calculate.
; Call with FLAG = current abnormal flag if any
;
; Returns NULL=no selection 0=Calculate from entered values
; 1=Abnormal Low 2=Critical Low
; 3=Abnormal High 4=Critical High
;
N DIR,DIROUT,DIRUT,DTOUT,X,Y
S DIR(0)="SOA^0:Calculate from entered values;1:Abnormal Low;2:Critical Low;3:Abnormal High;4:Critical High"
S DIR("A")="Result's Abnormality: "
S DIR("B")="Calculate from entered values"
I $G(FLAG)'="" S DIR("B")=$S(FLAG="L":"Abnormal Low",FLAG="L*":"Critical Low",FLAG="H":"Abnormal High",FLAG="H*":"Critical High",1:DIR("B"))
S DIR("?")="Select the abnormality if it cannot be calculated from reference values."
D ^DIR
I $D(DIRUT) S Y=""
Q Y
;
;
DCOM ; From above and LRVR4 - display comments
;
;ZEXCEPT: LRACC,LRCMTDSP,LRDFN,LRIDT,LRLCT,LRLDT,LRSS,Z2
;
; Quit if no current or previous comments
I '$O(^LR(LRDFN,LRSS,LRIDT,1,0)),'$O(^LR(LRDFN,LRSS,+$G(LRLDT),1,0)) Q
;
N DA
;
; Display previous comments.
I $G(LRCMTDSP),$G(LRLDT)>0,$O(^LR(LRDFN,LRSS,LRLDT,1,0)) D
. W !,"*** Comments for Previous Accession "_$P($G(Z2),"^",6)_" ***"
. S DA=LRLDT D DSPCMT
;
; Display current comments
I $O(^LR(LRDFN,LRSS,LRIDT,1,0)) D
. I $G(LRCMTDSP),$G(LRLDT)>0,$O(^LR(LRDFN,LRSS,LRLDT,1,0)) D
. . W !,"*** Comments for Current Accession "_$G(LRACC)_" ***"
. . S LRLCT=LRLCT+1
. S DA=LRIDT D DSPCMT
Q
;
;
CMTDSP ; Determine if display of previous results should include associated comments.
;
N ERR,I
;
; Get stored list of tests from parameter tool
K ^TMP("LRXPAR",$J),^TMP("LR",$J,"DCMT")
D GETLST^XPAR("^TMP(""LRXPAR"",$J)","USR","LR VER DISPLAY PREV COMMENT","Q",.ERR,1)
I '$G(^TMP("LRXPAR",$J)) Q
; Create list based in file #60 ien - makes checking easier
S I=0
F S I=$O(^TMP("LRXPAR",$J,I)) Q:'I I $P(^(I),"^",2) S ^TMP("LR",$J,"DCMT",+^TMP("LRXPAR",$J,I))=""
K ^TMP("LRXPAR",$J)
Q
;
;
CHKCDSP() ; Check if previous comment should display when test on user's list
; is present on test profile selected for this accession.
;
;ZEXCEPT: LRLDT,LRM
;
N I,OK
S OK=0
I $G(LRLDT)>0,$D(^TMP("LR",$J,"DCMT")) D
. S I=0
. F S I=$O(LRM(I)) Q:'I D Q:OK
. . I $D(^TMP("LR",$J,"DCMT",+LRM(I))) S OK=1 Q
. . I $G(LRM(I,"P")),$D(^TMP("LR",$J,"DCMT",+LRM(I,"P"))) S OK=1 Q
Q OK
;
;
DSPCMT ; Display comments stored in file #63
;
;ZEXCEPT: DA,IOST,LRDFN,LRLCT,LRSS
;
N DIR,DIRUT,DTOUT,DUOUT,I,X,Y
S I=0
F S I=$O(^LR(LRDFN,LRSS,DA,1,I)) Q:'I D Q:$D(DIRUT)
. S LRLCT=LRLCT+1
. W !,"COMMENTS: ",$P(^LR(LRDFN,LRSS,DA,1,I,0),"^")
. I LRLCT>21,$E(IOST,1,2)="C-" D Q:$D(DIRUT)
. . S DIR(0)="E" D ^DIR
. . S LRLCT=0
W ! S LRLCT=LRLCT+1
Q
;
;
DSPHW(LRDFN,LRY) ; Display patient's height and weight
; Call with LRDFN = file #63 ien
; LRY = array to return values, pass by value
;
; Returns array LRY with height and weight
;
N DFN,GMRVSTR,LRDPF,LREND,LRROOT,X
S X=$G(^LR(+LRDFN,0)),LRDPF=$P(X,"^",2),DFN=$P(X,"^",3),LREND=0
I LRDPF'=2 Q
K ^UTILITY($J,"GMRVD")
S GMRVSTR(0)="^^1^",GMRVSTR="HT;WT" D EN1^GMRVUT0
;
; -- Height = Ht.^value^in^metric^cm^^^[*]^Q1;..;Qn
; -- Weight = Wt.^value^lb^metric^kg^BodyMassIndex^^[*]^Q1;..;Qn
;
S LRROOT="^UTILITY($J,""GMRVD"")"
F S LRROOT=$Q(@LRROOT) Q:LRROOT="" D Q:LREND
. I $QS(LRROOT,1)'=$J!($QS(LRROOT,2)'="GMRVD") S LREND=1 Q
. S X=@LRROOT
. I $QS(LRROOT,3)="HT" S LRY("HT")="Ht.^"_$P(X,"^",8)_"^in^"_$P(X,"^",13)_"^cm^^"_$P(X,"^")_"^"_$P(X,"^",12)_"^"_$P(X,"^",17)
. I $QS(LRROOT,3)="WT" S LRY("WT")="Wt.^"_$P(X,"^",8)_"^lb^"_$P(X,"^",13)_"^kg^"_$P(X,"^",14)_"^"_$P(X,"^")_"^"_$P(X,U,12)_"^"_$P(X,"^",17)
;
K ^UTILITY($J,"GMRVD")
Q
;
;
XDELTACK ; Execute delta check in a controlled environment ("sand box")
;
;ZEXCEPT: LRDEL,LRDFN,LRIDT,LRLDT,LRSB,LRSPEC,LRSS
;
N LR60,LRDB,LRI,LROK,LRSBSAV
;
; Check for "delta check days back" (LRDB) cutoff on test/specimen
; Don't execute delta check if past test/specimen's "days back".
; If no value for "days back" then execute delta check.
; ^TMP("LR",543187985,"TMP",291) = 901
S LR60=+$G(^TMP("LR",$J,"TMP",LRSB)),LRDB=""
I LR60,$G(LRSPEC) S LRDB=$P($G(^LAB(60,LR60,1,LRSPEC,.1)),"^",2)
I LRDB'="" D Q:LROK=0
. I LRLDT<1 S LROK=0 Q
. N LRDATE
. S LROK=1,LRDATE(1)=$P(^LR(LRDFN,LRSS,LRIDT,0),"^"),LRDATE(2)=$P(^LR(LRDFN,LRSS,LRLDT,0),"^")
. I $$FMDIFF^XLFDT(LRDATE(1),LRDATE(2),1)>LRDB S LROK=0
;
; Save LRSB array
M LRSBSAV=LRSB
;
; Execute delta check, protect LRSBSAV array by NEWing
D
. N LRSBSAV
. X LRDEL
;
; Compare/restore LRSB array with LRSBSAV array to protect data in LRSB that may
; have been altered inappropriately in the delta check.
S LRI=0
F S LRI=$O(LRSBSAV(LRI)) Q:'LRI D
. I $D(LRSB(LRI)) S $P(LRSBSAV(LRI),"^")=$P(LRSB(LRI),"^")
;
; Merge LRSBSAV back into LRSB.
; Do not kill LRSB array in case new nodes created in LRSB by delta check
M LRSB=LRSBSAV
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRVERA 8630 printed Apr 09, 2024@21:19:34 Page 2
LRVERA ;DALOI/JMC - READ ACCESSION/UID ;06/01/10 11:50
+1 ;;5.2;LAB SERVICE;**153,271,286,350**;Sep 27, 1994;Build 230
+2 ;
+3 ; ZEXCEPT is used to identify variables which are external to a specific TAG
+4 ; used in conjunction with Eclipse M-editor.
+5 ;
ACC ; Prompt for accession selection
+1 DO EN^LRWU4
+2 QUIT
+3 ;
+4 ;
UID ; Prompt for UID selection
+1 ;
+2 ;ZEXCEPT: LRAA,LRAD,LRAN,LRUID
+3 ;
+4 NEW LRQUIT,LRX,LRY
+5 ;
+6 WRITE !
+7 SET (LRQUIT,LRY)=0
+8 FOR
Begin DoDot:1
+9 SET LRX=$$UID^LRWU4("Unique Identifier",$GET(LRUID))
+10 IF LRX=0
SET LRUID=""
SET (LRAA,LRAD,LRAN)=-1
SET LRQUIT=1
QUIT
+11 SET LRY=$$CHECKUID^LRWU4(LRX,"")
+12 IF LRY
SET LRQUIT=1
QUIT
+13 WRITE !,"No accession on file for this UID."
+14 SET LRUID=""
End DoDot:1
if LRQUIT
QUIT
+15 ;
+16 ; If good UID then update variables if user selected a different UID
+17 ; Display accession.
+18 IF LRY
Begin DoDot:1
+19 IF $GET(LRUID)'=LRX
SET LRUID=LRX
SET LRAA=$PIECE(LRY,"^",2)
SET LRAD=$PIECE(LRY,"^",3)
SET LRAN=$PIECE(LRY,"^",4)
+20 WRITE " (",$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^"),")"
End DoDot:1
+21 QUIT
+22 ;
+23 ;
SELPL(LR4,LRFLAG) ; Select the performing laboratory to store with test results.
+1 ; Call with LR4 = default institution, usually value of DUZ(2)
+2 ; LRFLAG = 0 (host lab only) / 1 (allow selection of collecting or host lab)
+3 ;
+4 ; Returns LR4 = ien of file #4 institution selected
+5 ;
+6 NEW DIC,DTOUT,DUOUT,X,Y
+7 SET DIC="^DIC(4,"
SET DIC(0)="AEMOQ"
SET LRFLAG=+$GET(LRFLAG)
+8 SET DIC("A")="Select Performing Laboratory: "
+9 IF $GET(LR4)>0
SET DIC("B")=$$GET1^DIQ(4,LR4_",",.01)
+10 SET DIC("S")="I $$SCRNPL^LRVERA(LRFLAG)"
+11 DO ^DIC
+12 IF Y<1
SET LR4=0
+13 IF '$TEST
SET LR4=$PIECE(Y,"^")
+14 ;
+15 QUIT LR4
+16 ;
+17 ;
SCRNPL(LRFLAG) ; Screen performing laboratory
+1 ; Called by DIC("S") lookup above when selecting performing laboratory
+2 ; Call with LRFLAG = allow selection of collecting or host lab
+3 ;
+4 ;ZEXCEPT: Y
+5 ;
+6 NEW OK
+7 SET OK=0
+8 IF Y=DUZ(2)
SET OK=1
+9 IF 'OK
Begin DoDot:1
+10 IF $DATA(^LAHM(62.9,"CH",DUZ(2),Y))
SET OK=1
QUIT
+11 IF LRFLAG
IF $DATA(^LAHM(62.9,"CH",Y,DUZ(2)))
SET OK=1
End DoDot:1
+12 ;
+13 QUIT OK
+14 ;
+15 ;
PLOK(LRX,LRY,LRZ,LR60) ; Check if user is editing results that appear to have
+1 ; been performed by a lab different from the one they selected and.
+2 ; ask if changing performing lab is ok.
+3 ;
+4 ; Call with LRX = file #4 ien of performing lab on record
+5 ; LRY = file #4 ien of performing lab user selected
+6 ; LRZ = user's current division - DUZ(2)
+7 ; LR60 = file #60 ien of test selected
+8 ;
+9 ; Returns 1=YES, 0=NO
+10 ;
+11 NEW DIR,DIRUT,DTOUT,DUOUT,OK,X,Y
+12 SET OK=1
+13 IF LRX
Begin DoDot:1
+14 IF LRY
IF LRX=LRY
QUIT
+15 IF LRX=LRZ
QUIT
+16 SET DIR("A",1)="The performing lab recorded for test "_$$GET1^DIQ(60,LR60_",",.01)_" is: "_$$GET1^DIQ(4,LRX_",",.01)
+17 SET DIR("A",2)="You indicated the performing lab is: "_$$GET1^DIQ(4,$SELECT(LRY:LRY,1:LRZ)_",",.01)
+18 SET DIR("A")="Do you want to continue"
SET DIR("B")="NO"
+19 SET DIR(0)="YO"
SET OK=0
+20 WRITE !
DO ^DIR
+21 IF Y=1
SET OK=1
End DoDot:1
+22 QUIT OK
+23 ;
+24 ;
SETRL(LRDFN,LRSS,LRIDT,LR4) ; Set reporting laboratory for entry in file #63
+1 ; Call with LRDFN = File #63 IEN
+2 ; LRSS = file #63 subscript
+3 ; LRIDT = inverse date/time of specimen ("AU" should pass 0)
+4 ; LR4 = file #4 IEN to store as reporting laboratory
+5 ;
+6 NEW FDA,LRDIE,LRFILE
+7 ;
+8 IF LRSS'="AU"
IF (LRDFN*LRIDT*LR4)<1
QUIT
+9 IF LRSS'="AU"
IF LR4=+$GET(^LR(LRDFN,LRSS,LRIDT,"RF"))
QUIT
+10 IF LRSS="AU"
IF LR4=$PIECE($GET(^LR(LRDFN,"AU")),"^",18)
QUIT
+11 ;
+12 SET LRFILE=$SELECT(LRSS="CH":63.04,LRSS="MI":63.05,LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,LRSS="AU":63,1:0)
+13 IF LRFILE<1
QUIT
+14 ;
+15 IF LRSS'="AU"
SET FDA(1,LRFILE,LRIDT_","_LRDFN_",",.345)=LR4
+16 IF '$TEST
SET FDA(1,LRFILE,LRDFN_",",14.91)=LR4
+17 DO FILE^DIE("","FDA(1)","LRDIE(1)")
+18 ;
+19 QUIT
+20 ;
+21 ;
RFLAG(FLAG) ; Ask user for referral high/low/critical flag in case they
+1 ; don't have values to calculate.
+2 ; Call with FLAG = current abnormal flag if any
+3 ;
+4 ; Returns NULL=no selection 0=Calculate from entered values
+5 ; 1=Abnormal Low 2=Critical Low
+6 ; 3=Abnormal High 4=Critical High
+7 ;
+8 NEW DIR,DIROUT,DIRUT,DTOUT,X,Y
+9 SET DIR(0)="SOA^0:Calculate from entered values;1:Abnormal Low;2:Critical Low;3:Abnormal High;4:Critical High"
+10 SET DIR("A")="Result's Abnormality: "
+11 SET DIR("B")="Calculate from entered values"
+12 IF $GET(FLAG)'=""
SET DIR("B")=$SELECT(FLAG="L":"Abnormal Low",FLAG="L*":"Critical Low",FLAG="H":"Abnormal High",FLAG="H*":"Critical High",1:DIR("B"))
+13 SET DIR("?")="Select the abnormality if it cannot be calculated from reference values."
+14 DO ^DIR
+15 IF $DATA(DIRUT)
SET Y=""
+16 QUIT Y
+17 ;
+18 ;
DCOM ; From above and LRVR4 - display comments
+1 ;
+2 ;ZEXCEPT: LRACC,LRCMTDSP,LRDFN,LRIDT,LRLCT,LRLDT,LRSS,Z2
+3 ;
+4 ; Quit if no current or previous comments
+5 IF '$ORDER(^LR(LRDFN,LRSS,LRIDT,1,0))
IF '$ORDER(^LR(LRDFN,LRSS,+$GET(LRLDT),1,0))
QUIT
+6 ;
+7 NEW DA
+8 ;
+9 ; Display previous comments.
+10 IF $GET(LRCMTDSP)
IF $GET(LRLDT)>0
IF $ORDER(^LR(LRDFN,LRSS,LRLDT,1,0))
Begin DoDot:1
+11 WRITE !,"*** Comments for Previous Accession "_$PIECE($GET(Z2),"^",6)_" ***"
+12 SET DA=LRLDT
DO DSPCMT
End DoDot:1
+13 ;
+14 ; Display current comments
+15 IF $ORDER(^LR(LRDFN,LRSS,LRIDT,1,0))
Begin DoDot:1
+16 IF $GET(LRCMTDSP)
IF $GET(LRLDT)>0
IF $ORDER(^LR(LRDFN,LRSS,LRLDT,1,0))
Begin DoDot:2
+17 WRITE !,"*** Comments for Current Accession "_$GET(LRACC)_" ***"
+18 SET LRLCT=LRLCT+1
End DoDot:2
+19 SET DA=LRIDT
DO DSPCMT
End DoDot:1
+20 QUIT
+21 ;
+22 ;
CMTDSP ; Determine if display of previous results should include associated comments.
+1 ;
+2 NEW ERR,I
+3 ;
+4 ; Get stored list of tests from parameter tool
+5 KILL ^TMP("LRXPAR",$JOB),^TMP("LR",$JOB,"DCMT")
+6 DO GETLST^XPAR("^TMP(""LRXPAR"",$J)","USR","LR VER DISPLAY PREV COMMENT","Q",.ERR,1)
+7 IF '$GET(^TMP("LRXPAR",$JOB))
QUIT
+8 ; Create list based in file #60 ien - makes checking easier
+9 SET I=0
+10 FOR
SET I=$ORDER(^TMP("LRXPAR",$JOB,I))
if 'I
QUIT
IF $PIECE(^(I),"^",2)
SET ^TMP("LR",$JOB,"DCMT",+^TMP("LRXPAR",$JOB,I))=""
+11 KILL ^TMP("LRXPAR",$JOB)
+12 QUIT
+13 ;
+14 ;
CHKCDSP() ; Check if previous comment should display when test on user's list
+1 ; is present on test profile selected for this accession.
+2 ;
+3 ;ZEXCEPT: LRLDT,LRM
+4 ;
+5 NEW I,OK
+6 SET OK=0
+7 IF $GET(LRLDT)>0
IF $DATA(^TMP("LR",$JOB,"DCMT"))
Begin DoDot:1
+8 SET I=0
+9 FOR
SET I=$ORDER(LRM(I))
if 'I
QUIT
Begin DoDot:2
+10 IF $DATA(^TMP("LR",$JOB,"DCMT",+LRM(I)))
SET OK=1
QUIT
+11 IF $GET(LRM(I,"P"))
IF $DATA(^TMP("LR",$JOB,"DCMT",+LRM(I,"P")))
SET OK=1
QUIT
End DoDot:2
if OK
QUIT
End DoDot:1
+12 QUIT OK
+13 ;
+14 ;
DSPCMT ; Display comments stored in file #63
+1 ;
+2 ;ZEXCEPT: DA,IOST,LRDFN,LRLCT,LRSS
+3 ;
+4 NEW DIR,DIRUT,DTOUT,DUOUT,I,X,Y
+5 SET I=0
+6 FOR
SET I=$ORDER(^LR(LRDFN,LRSS,DA,1,I))
if 'I
QUIT
Begin DoDot:1
+7 SET LRLCT=LRLCT+1
+8 WRITE !,"COMMENTS: ",$PIECE(^LR(LRDFN,LRSS,DA,1,I,0),"^")
+9 IF LRLCT>21
IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:2
+10 SET DIR(0)="E"
DO ^DIR
+11 SET LRLCT=0
End DoDot:2
if $DATA(DIRUT)
QUIT
End DoDot:1
if $DATA(DIRUT)
QUIT
+12 WRITE !
SET LRLCT=LRLCT+1
+13 QUIT
+14 ;
+15 ;
DSPHW(LRDFN,LRY) ; Display patient's height and weight
+1 ; Call with LRDFN = file #63 ien
+2 ; LRY = array to return values, pass by value
+3 ;
+4 ; Returns array LRY with height and weight
+5 ;
+6 NEW DFN,GMRVSTR,LRDPF,LREND,LRROOT,X
+7 SET X=$GET(^LR(+LRDFN,0))
SET LRDPF=$PIECE(X,"^",2)
SET DFN=$PIECE(X,"^",3)
SET LREND=0
+8 IF LRDPF'=2
QUIT
+9 KILL ^UTILITY($JOB,"GMRVD")
+10 SET GMRVSTR(0)="^^1^"
SET GMRVSTR="HT;WT"
DO EN1^GMRVUT0
+11 ;
+12 ; -- Height = Ht.^value^in^metric^cm^^^[*]^Q1;..;Qn
+13 ; -- Weight = Wt.^value^lb^metric^kg^BodyMassIndex^^[*]^Q1;..;Qn
+14 ;
+15 SET LRROOT="^UTILITY($J,""GMRVD"")"
+16 FOR
SET LRROOT=$QUERY(@LRROOT)
if LRROOT=""
QUIT
Begin DoDot:1
+17 IF $QSUBSCRIPT(LRROOT,1)'=$JOB!($QSUBSCRIPT(LRROOT,2)'="GMRVD")
SET LREND=1
QUIT
+18 SET X=@LRROOT
+19 IF $QSUBSCRIPT(LRROOT,3)="HT"
SET LRY("HT")="Ht.^"_$PIECE(X,"^",8)_"^in^"_$PIECE(X,"^",13)_"^cm^^"_$PIECE(X,"^")_"^"_$PIECE(X,"^",12)_"^"_$PIECE(X,"^",17)
+20 IF $QSUBSCRIPT(LRROOT,3)="WT"
SET LRY("WT")="Wt.^"_$PIECE(X,"^",8)_"^lb^"_$PIECE(X,"^",13)_"^kg^"_$PIECE(X,"^",14)_"^"_$PIECE(X,"^")_"^"_$PIECE(X,U,12)_"^"_$PIECE(X,"^",17)
End DoDot:1
if LREND
QUIT
+21 ;
+22 KILL ^UTILITY($JOB,"GMRVD")
+23 QUIT
+24 ;
+25 ;
XDELTACK ; Execute delta check in a controlled environment ("sand box")
+1 ;
+2 ;ZEXCEPT: LRDEL,LRDFN,LRIDT,LRLDT,LRSB,LRSPEC,LRSS
+3 ;
+4 NEW LR60,LRDB,LRI,LROK,LRSBSAV
+5 ;
+6 ; Check for "delta check days back" (LRDB) cutoff on test/specimen
+7 ; Don't execute delta check if past test/specimen's "days back".
+8 ; If no value for "days back" then execute delta check.
+9 ; ^TMP("LR",543187985,"TMP",291) = 901
+10 SET LR60=+$GET(^TMP("LR",$JOB,"TMP",LRSB))
SET LRDB=""
+11 IF LR60
IF $GET(LRSPEC)
SET LRDB=$PIECE($GET(^LAB(60,LR60,1,LRSPEC,.1)),"^",2)
+12 IF LRDB'=""
Begin DoDot:1
+13 IF LRLDT<1
SET LROK=0
QUIT
+14 NEW LRDATE
+15 SET LROK=1
SET LRDATE(1)=$PIECE(^LR(LRDFN,LRSS,LRIDT,0),"^")
SET LRDATE(2)=$PIECE(^LR(LRDFN,LRSS,LRLDT,0),"^")
+16 IF $$FMDIFF^XLFDT(LRDATE(1),LRDATE(2),1)>LRDB
SET LROK=0
End DoDot:1
if LROK=0
QUIT
+17 ;
+18 ; Save LRSB array
+19 MERGE LRSBSAV=LRSB
+20 ;
+21 ; Execute delta check, protect LRSBSAV array by NEWing
+22 Begin DoDot:1
+23 NEW LRSBSAV
+24 XECUTE LRDEL
End DoDot:1
+25 ;
+26 ; Compare/restore LRSB array with LRSBSAV array to protect data in LRSB that may
+27 ; have been altered inappropriately in the delta check.
+28 SET LRI=0
+29 FOR
SET LRI=$ORDER(LRSBSAV(LRI))
if 'LRI
QUIT
Begin DoDot:1
+30 IF $DATA(LRSB(LRI))
SET $PIECE(LRSBSAV(LRI),"^")=$PIECE(LRSB(LRI),"^")
End DoDot:1
+31 ;
+32 ; Merge LRSBSAV back into LRSB.
+33 ; Do not kill LRSB array in case new nodes created in LRSB by delta check
+34 MERGE LRSB=LRSBSAV
+35 ;
+36 QUIT
