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 ;VA/DALOI/JMC - READ ACCESSION/UID ;JUL 06, 2010 3:14 PM
  1.  ;;5.2;LAB SERVICE;**153,271,286,1027**;NOV 01, 1997
  1.  ;
  1.  ;
  1. ACC ; Prompt for accession selection
  1.  D EN^LRWU4
  1.  Q
  1.  ;
  1.  ;
  1. UID ; Prompt for UID selection
  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) ; Select the performing laboratory to store with test results.
  1.  ; Call with LR4 = default institution, usually value of DUZ(2)
  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"
  1.  ; S DIC("A")="Select Performing Laboratory: "
  1.  S DIC("A")="Select Referring Laboratory: "      ; IHS/OIT/MKK - LR*5.2*1027
  1.  I $G(LR4)>0 S DIC("B")=$$GET1^DIQ(4,LR4_",",.01)
  1.  S DIC("S")="I $$SCRNPL^LRVERA"
  1.  D ^DIC
  1.  I Y<1 S LR4=0
  1.  E  S LR4=$P(Y,"^")
  1.  ;
  1.  Q LR4
  1.  ;
  1.  ;
  1. SCRNPL() ; Screen performing laboratory
  1.  ; Called by DIC("S") lookup above when selecting performing laboratory
  1.  N OK,LRX
  1.  S OK=0
  1.  I Y=DUZ(2) S OK=1
  1.  E  I $D(^LAHM(62.9,"CH",DUZ(2),Y)) S OK=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. 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.  ; 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.  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.  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