Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRVERA

LRVERA.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; ZEXCEPT is used to identify variables which are external to a specific TAG
  1. ; used in conjunction with Eclipse M-editor.
  1. ;
  1. ACC ; Prompt for accession selection
  1. D EN^LRWU4
  1. Q
  1. ;
  1. ;
  1. UID ; Prompt for UID selection
  1. ;
  1. ;ZEXCEPT: LRAA,LRAD,LRAN,LRUID
  1. ;
  1. N LRQUIT,LRX,LRY
  1. ;
  1. W !
  1. S (LRQUIT,LRY)=0
  1. F D Q:LRQUIT
  1. . S LRX=$$UID^LRWU4("Unique Identifier",$G(LRUID))
  1. . I LRX=0 S LRUID="",(LRAA,LRAD,LRAN)=-1,LRQUIT=1 Q
  1. . S LRY=$$CHECKUID^LRWU4(LRX,"")
  1. . I LRY S LRQUIT=1 Q
  1. . W !,"No accession on file for this UID."
  1. . S LRUID=""
  1. ;
  1. ; If good UID then update variables if user selected a different UID
  1. ; Display accession.
  1. I LRY D
  1. . I $G(LRUID)'=LRX S LRUID=LRX,LRAA=$P(LRY,"^",2),LRAD=$P(LRY,"^",3),LRAN=$P(LRY,"^",4)
  1. . W " (",$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^"),")"
  1. Q
  1. ;
  1. ;
  1. SELPL(LR4,LRFLAG) ; Select the performing laboratory to store with test results.
  1. ; Call with LR4 = default institution, usually value of DUZ(2)
  1. ; LRFLAG = 0 (host lab only) / 1 (allow selection of collecting or host lab)
  1. ;
  1. ; Returns LR4 = ien of file #4 institution selected
  1. ;
  1. N DIC,DTOUT,DUOUT,X,Y
  1. S DIC="^DIC(4,",DIC(0)="AEMOQ",LRFLAG=+$G(LRFLAG)
  1. S DIC("A")="Select Performing Laboratory: "
  1. I $G(LR4)>0 S DIC("B")=$$GET1^DIQ(4,LR4_",",.01)
  1. S DIC("S")="I $$SCRNPL^LRVERA(LRFLAG)"
  1. D ^DIC
  1. I Y<1 S LR4=0
  1. E S LR4=$P(Y,"^")
  1. ;
  1. Q LR4
  1. ;
  1. ;
  1. SCRNPL(LRFLAG) ; Screen performing laboratory
  1. ; Called by DIC("S") lookup above when selecting performing laboratory
  1. ; Call with LRFLAG = allow selection of collecting or host lab
  1. ;
  1. ;ZEXCEPT: Y
  1. ;
  1. N OK
  1. S OK=0
  1. I Y=DUZ(2) S OK=1
  1. I 'OK D
  1. . I $D(^LAHM(62.9,"CH",DUZ(2),Y)) S OK=1 Q
  1. . I LRFLAG,$D(^LAHM(62.9,"CH",Y,DUZ(2))) S OK=1
  1. ;
  1. Q OK
  1. ;
  1. ;
  1. 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.
  1. ; ask if changing performing lab is ok.
  1. ;
  1. ; Call with LRX = file #4 ien of performing lab on record
  1. ; LRY = file #4 ien of performing lab user selected
  1. ; LRZ = user's current division - DUZ(2)
  1. ; LR60 = file #60 ien of test selected
  1. ;
  1. ; Returns 1=YES, 0=NO
  1. ;
  1. N DIR,DIRUT,DTOUT,DUOUT,OK,X,Y
  1. S OK=1
  1. I LRX D
  1. . I LRY,LRX=LRY Q
  1. . I LRX=LRZ Q
  1. . S DIR("A",1)="The performing lab recorded for test "_$$GET1^DIQ(60,LR60_",",.01)_" is: "_$$GET1^DIQ(4,LRX_",",.01)
  1. . S DIR("A",2)="You indicated the performing lab is: "_$$GET1^DIQ(4,$S(LRY:LRY,1:LRZ)_",",.01)
  1. . S DIR("A")="Do you want to continue",DIR("B")="NO"
  1. . S DIR(0)="YO",OK=0
  1. . W ! D ^DIR
  1. . I Y=1 S OK=1
  1. Q OK
  1. ;
  1. ;
  1. SETRL(LRDFN,LRSS,LRIDT,LR4) ; Set reporting laboratory for entry in file #63
  1. ; Call with LRDFN = File #63 IEN
  1. ; LRSS = file #63 subscript
  1. ; LRIDT = inverse date/time of specimen ("AU" should pass 0)
  1. ; LR4 = file #4 IEN to store as reporting laboratory
  1. ;
  1. N FDA,LRDIE,LRFILE
  1. ;
  1. I LRSS'="AU",(LRDFN*LRIDT*LR4)<1 Q
  1. I LRSS'="AU",LR4=+$G(^LR(LRDFN,LRSS,LRIDT,"RF")) Q
  1. I LRSS="AU",LR4=$P($G(^LR(LRDFN,"AU")),"^",18) Q
  1. ;
  1. 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)
  1. I LRFILE<1 Q
  1. ;
  1. I LRSS'="AU" S FDA(1,LRFILE,LRIDT_","_LRDFN_",",.345)=LR4
  1. E S FDA(1,LRFILE,LRDFN_",",14.91)=LR4
  1. D FILE^DIE("","FDA(1)","LRDIE(1)")
  1. ;
  1. Q
  1. ;
  1. ;
  1. RFLAG(FLAG) ; Ask user for referral high/low/critical flag in case they
  1. ; don't have values to calculate.
  1. ; Call with FLAG = current abnormal flag if any
  1. ;
  1. ; Returns NULL=no selection 0=Calculate from entered values
  1. ; 1=Abnormal Low 2=Critical Low
  1. ; 3=Abnormal High 4=Critical High
  1. ;
  1. N DIR,DIROUT,DIRUT,DTOUT,X,Y
  1. S DIR(0)="SOA^0:Calculate from entered values;1:Abnormal Low;2:Critical Low;3:Abnormal High;4:Critical High"
  1. S DIR("A")="Result's Abnormality: "
  1. S DIR("B")="Calculate from entered values"
  1. 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"))
  1. S DIR("?")="Select the abnormality if it cannot be calculated from reference values."
  1. D ^DIR
  1. I $D(DIRUT) S Y=""
  1. Q Y
  1. ;
  1. ;
  1. DCOM ; From above and LRVR4 - display comments
  1. ;
  1. ;ZEXCEPT: LRACC,LRCMTDSP,LRDFN,LRIDT,LRLCT,LRLDT,LRSS,Z2
  1. ;
  1. ; Quit if no current or previous comments
  1. I '$O(^LR(LRDFN,LRSS,LRIDT,1,0)),'$O(^LR(LRDFN,LRSS,+$G(LRLDT),1,0)) Q
  1. ;
  1. N DA
  1. ;
  1. ; Display previous comments.
  1. I $G(LRCMTDSP),$G(LRLDT)>0,$O(^LR(LRDFN,LRSS,LRLDT,1,0)) D
  1. . W !,"*** Comments for Previous Accession "_$P($G(Z2),"^",6)_" ***"
  1. . S DA=LRLDT D DSPCMT
  1. ;
  1. ; Display current comments
  1. I $O(^LR(LRDFN,LRSS,LRIDT,1,0)) D
  1. . I $G(LRCMTDSP),$G(LRLDT)>0,$O(^LR(LRDFN,LRSS,LRLDT,1,0)) D
  1. . . W !,"*** Comments for Current Accession "_$G(LRACC)_" ***"
  1. . . S LRLCT=LRLCT+1
  1. . S DA=LRIDT D DSPCMT
  1. Q
  1. ;
  1. ;
  1. CMTDSP ; Determine if display of previous results should include associated comments.
  1. ;
  1. N ERR,I
  1. ;
  1. ; Get stored list of tests from parameter tool
  1. K ^TMP("LRXPAR",$J),^TMP("LR",$J,"DCMT")
  1. D GETLST^XPAR("^TMP(""LRXPAR"",$J)","USR","LR VER DISPLAY PREV COMMENT","Q",.ERR,1)
  1. I '$G(^TMP("LRXPAR",$J)) Q
  1. ; Create list based in file #60 ien - makes checking easier
  1. S I=0
  1. F S I=$O(^TMP("LRXPAR",$J,I)) Q:'I I $P(^(I),"^",2) S ^TMP("LR",$J,"DCMT",+^TMP("LRXPAR",$J,I))=""
  1. K ^TMP("LRXPAR",$J)
  1. Q
  1. ;
  1. ;
  1. CHKCDSP() ; Check if previous comment should display when test on user's list
  1. ; is present on test profile selected for this accession.
  1. ;
  1. ;ZEXCEPT: LRLDT,LRM
  1. ;
  1. N I,OK
  1. S OK=0
  1. I $G(LRLDT)>0,$D(^TMP("LR",$J,"DCMT")) D
  1. . S I=0
  1. . F S I=$O(LRM(I)) Q:'I D Q:OK
  1. . . I $D(^TMP("LR",$J,"DCMT",+LRM(I))) S OK=1 Q
  1. . . I $G(LRM(I,"P")),$D(^TMP("LR",$J,"DCMT",+LRM(I,"P"))) S OK=1 Q
  1. Q OK
  1. ;
  1. ;
  1. DSPCMT ; Display comments stored in file #63
  1. ;
  1. ;ZEXCEPT: DA,IOST,LRDFN,LRLCT,LRSS
  1. ;
  1. N DIR,DIRUT,DTOUT,DUOUT,I,X,Y
  1. S I=0
  1. F S I=$O(^LR(LRDFN,LRSS,DA,1,I)) Q:'I D Q:$D(DIRUT)
  1. . S LRLCT=LRLCT+1
  1. . W !,"COMMENTS: ",$P(^LR(LRDFN,LRSS,DA,1,I,0),"^")
  1. . I LRLCT>21,$E(IOST,1,2)="C-" D Q:$D(DIRUT)
  1. . . S DIR(0)="E" D ^DIR
  1. . . S LRLCT=0
  1. W ! S LRLCT=LRLCT+1
  1. Q
  1. ;
  1. ;
  1. DSPHW(LRDFN,LRY) ; Display patient's height and weight
  1. ; Call with LRDFN = file #63 ien
  1. ; LRY = array to return values, pass by value
  1. ;
  1. ; Returns array LRY with height and weight
  1. ;
  1. N DFN,GMRVSTR,LRDPF,LREND,LRROOT,X
  1. S X=$G(^LR(+LRDFN,0)),LRDPF=$P(X,"^",2),DFN=$P(X,"^",3),LREND=0
  1. I LRDPF'=2 Q
  1. K ^UTILITY($J,"GMRVD")
  1. S GMRVSTR(0)="^^1^",GMRVSTR="HT;WT" D EN1^GMRVUT0
  1. ;
  1. ; -- Height = Ht.^value^in^metric^cm^^^[*]^Q1;..;Qn
  1. ; -- Weight = Wt.^value^lb^metric^kg^BodyMassIndex^^[*]^Q1;..;Qn
  1. ;
  1. S LRROOT="^UTILITY($J,""GMRVD"")"
  1. F S LRROOT=$Q(@LRROOT) Q:LRROOT="" D Q:LREND
  1. . I $QS(LRROOT,1)'=$J!($QS(LRROOT,2)'="GMRVD") S LREND=1 Q
  1. . S X=@LRROOT
  1. . 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)
  1. . 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)
  1. ;
  1. K ^UTILITY($J,"GMRVD")
  1. Q
  1. ;
  1. ;
  1. XDELTACK ; Execute delta check in a controlled environment ("sand box")
  1. ;
  1. ;ZEXCEPT: LRDEL,LRDFN,LRIDT,LRLDT,LRSB,LRSPEC,LRSS
  1. ;
  1. N LR60,LRDB,LRI,LROK,LRSBSAV
  1. ;
  1. ; Check for "delta check days back" (LRDB) cutoff on test/specimen
  1. ; Don't execute delta check if past test/specimen's "days back".
  1. ; If no value for "days back" then execute delta check.
  1. ; ^TMP("LR",543187985,"TMP",291) = 901
  1. S LR60=+$G(^TMP("LR",$J,"TMP",LRSB)),LRDB=""
  1. I LR60,$G(LRSPEC) S LRDB=$P($G(^LAB(60,LR60,1,LRSPEC,.1)),"^",2)
  1. I LRDB'="" D Q:LROK=0
  1. . I LRLDT<1 S LROK=0 Q
  1. . N LRDATE
  1. . S LROK=1,LRDATE(1)=$P(^LR(LRDFN,LRSS,LRIDT,0),"^"),LRDATE(2)=$P(^LR(LRDFN,LRSS,LRLDT,0),"^")
  1. . I $$FMDIFF^XLFDT(LRDATE(1),LRDATE(2),1)>LRDB S LROK=0
  1. ;
  1. ; Save LRSB array
  1. M LRSBSAV=LRSB
  1. ;
  1. ; Execute delta check, protect LRSBSAV array by NEWing
  1. D
  1. . N LRSBSAV
  1. . X LRDEL
  1. ;
  1. ; Compare/restore LRSB array with LRSBSAV array to protect data in LRSB that may
  1. ; have been altered inappropriately in the delta check.
  1. S LRI=0
  1. F S LRI=$O(LRSBSAV(LRI)) Q:'LRI D
  1. . I $D(LRSB(LRI)) S $P(LRSBSAV(LRI),"^")=$P(LRSB(LRI),"^")
  1. ;
  1. ; Merge LRSBSAV back into LRSB.
  1. ; Do not kill LRSB array in case new nodes created in LRSB by delta check
  1. M LRSB=LRSBSAV
  1. ;
  1. Q