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

BQITAXX2.m

Go to the documentation of this file. 
  1. BQITAXX2 ;PRXM/HC/ALA - Add Taxonomy Item ; 26 May 2006  2:00 PM
  1.  ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
  1.  ;
  1.  Q
  1.  ;
  1. ADD(DATA,TVALUE,LOW,HIGH) ;EP -- BQI ADD TAXONOMY ITEM
  1.  ;
  1.  ;Input
  1.  ;  TVALUE - Taxonomy pointer
  1.  ;  LOW    - Low value
  1.  ;  HIGH   - High value
  1.  ;
  1.  NEW UID,II,X
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQITXADD",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQITAXX2 D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  I '$$KEYCHK^BQIULSC("BQIZTXED",DUZ) S BMXSEC="You do not have the security access to edit a taxonomy."_$C(10)_"Please see your supervisor or program manager." Q
  1.  ;I '$$KEYCHK^BQIULSC("BGPZ TAXONOMY EDIT",DUZ) S BMXSEC="You do not have the security access to edit a taxonomy."_$C(10)_"Please see your supervisor or program manager." Q
  1.  ;
  1.  S TVALUE=$G(TVALUE,""),LOW=$G(LOW,""),HIGH=$G(HIGH,"")
  1.  I TVALUE="" S BMXSEC="No taxonomy identified" Q
  1.  I LOW="" S BMXSEC="No LOW value submitted" Q
  1.  ;
  1.  S @DATA@(II)="I00010RESULT"_$C(30)
  1.  ;
  1.  NEW FILE,SBFILE,DA,DIC,Y,RESULT,BQIUPD,CANON,IEN
  1.  S FILE=$$GREF^BQITAXX(TVALUE),IEN=$P(TVALUE,";",1),CANON=0
  1.  I FILE=9002226 S SBFILE=FILE_".02101",CANON=$$GET1^DIQ(FILE,IEN_",",.13,"I")
  1.  I FILE=9002228 S SBFILE=FILE_".04101"
  1.  I CANON D
  1.  . I LOW["."!($E(LOW,1,1)="0")!($E(LOW,$L(LOW),$L(LOW))=0) S LOW=LOW_" "
  1.  . I HIGH["."!($E(HIGH,1,1)="0")!($E(HIGH,$L(HIGH),$L(HIGH))=0) S HIGH=HIGH_" "
  1.  ;
  1.  S DA(1)=$P(TVALUE,";",1),DIC="^"_$P(TVALUE,";",2)_DA(1)_",21,"
  1.  S DIC(0)="L",X=LOW
  1.  K DO,DD D FILE^DICN
  1.  I Y<1 S RESULT=-1
  1.  I +Y>0 S RESULT=1,DA=+Y D
  1.  . NEW IENS
  1.  . S IENS=$$IENS^DILF(.DA)
  1.  . S BQIUPD(SBFILE,IENS,.02)=$S(HIGH'="":HIGH,1:LOW)
  1.  . I FILE=9002228 D  ; Updated by/date are unique to ^ATXLAB
  1.  .. S BQIUPD(FILE,DA(1)_",",.05)=DUZ
  1.  .. S BQIUPD(FILE,DA(1)_",",.06)=DT
  1.  . D FILE^DIE("","BQIUPD","ERROR")
  1.  . K BQIUPD
  1.  S II=II+1,@DATA@(II)=RESULT_$C(30)
  1.  Q
  1.  ;
  1. LKP(DATA,TVALUE,FNBR,VALUE) ;EP -- BQI LOOKUP TAXONOMY ITEM
  1.  ;
  1.  ;Input
  1.  ;  TVALUE - Taxonomy pointer
  1.  ;  FNBR  - File number to look up value
  1.  ;  VALUE - Value to look up in File number
  1.  ;
  1.  NEW UID,II,X
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BQITXLKP",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQITAXX2 D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S FNBR=$G(FNBR,""),VALUE=$G(VALUE,""),TVALUE=$G(TVALUE,"")
  1.  I TVALUE="" S BMXSEC="No taxonomy identified" Q
  1.  I VALUE="" S BMXSEC="No value to look up" Q
  1.  ;
  1.  ; if there were no values in the taxonomy before, there may not be
  1.  ; a file number passed so determine it from taxonomy
  1.  I FNBR="" D
  1.  . NEW IEN,FILE,ROOT,FLD
  1.  . S IEN=$P(TVALUE,";",1),FILE=$$GREF^BQITAXX(TVALUE),ROOT=$$ROOT^DILFD(FILE,"",1)
  1.  . I FILE=9002226 S FLD=".15"
  1.  . I FILE=9002228 S FLD=".09"
  1.  . S FNBR=$$GET1^DIQ(FILE,IEN,FLD,"I")
  1.  I FNBR="" S BMXSEC="No file identified to search for value" Q
  1.  ;
  1.  NEW FILE,FIELD,XREF,FLAGS,NUMB,SCREEN,JJ,IEN,TEXT,DESC
  1.  NEW MAP,HDR,MII,NFLD,TYPE,VERSION
  1.  S FILE=FNBR,XREF="",NUMB="*",SCREEN="",VERSION=$$VERSION^XPDUTL("PSS")
  1.  ;S FIELD=".01"
  1.  S FIELD="FID;-WID"
  1.  I FNBR=50,VERSION'="" S FIELD=FIELD_";31"
  1.  I FNBR=50,VERSION="" S FIELD=".01"
  1.  ;S FLAGS=$S(FILE=95.3:"P",1:"MP")
  1.  S FLAGS="MP"
  1.  D FIND^DIC(FILE,"",FIELD,FLAGS,VALUE,"",XREF,SCREEN,"","","ERROR")
  1.  ;
  1.  S MAP=$G(^TMP("DILIST",$J,0,"MAP"))
  1.  I FNBR=50,VERSION="" S MAP="IEN^.01I^100^31"
  1.  I MAP="" S @DATA@(II)="I00010IEN^T00030TEXT^T00120DESCRIPTION"_$C(30)
  1.  I MAP'="" D
  1.  . S HDR=""
  1.  . F MII=1:1:$L(MAP,"^") D
  1.  .. I $P(MAP,"^",MII)="IEN" S HDR=HDR_"I00010IEN^" Q
  1.  .. I $P(MAP,"^",MII)[".01" D CHK(.01) S HDR=HDR_TYPE_"^" Q
  1.  .. S NFLD=$P(MAP,"^",MII)
  1.  .. I NFLD["FID(" S NFLD=$P($P(NFLD,"FID(",2),")",1) D CHK(NFLD) S HDR=HDR_TYPE_"^" Q
  1.  .. D CHK(NFLD) S HDR=HDR_TYPE_"^"
  1.  . S HDR=$$TKO^BQIUL1(HDR,"^")
  1.  . I FNBR=9999999.05 F MII=1:1:$L(HDR,"^") D
  1.  .. I $P(HDR,"^",MII)="T00003CODE" S $P(HDR,"^",MII)="T00003COMM_CODE"
  1.  .. I $P(HDR,"^",MII)="T00030NAME" S $P(HDR,"^",MII)="T00030COMM_NAME"
  1.  . S @DATA@(II)=HDR_$C(30)
  1.  S JJ=0
  1.  F  S JJ=$O(^TMP("DILIST",$J,JJ)) Q:'JJ  D
  1.  . I MAP="" D
  1.  .. S IEN=$P(^TMP("DILIST",$J,JJ,0),U,1)
  1.  .. S TEXT=$P(^TMP("DILIST",$J,JJ,0),U,2)
  1.  .. S DESC=""
  1.  .. S FLD=$S(FNBR=80:3,FNBR=80.1:4,FNBR=81:2,FNBR=9999999.31:.02,1:"")
  1.  .. I FLD'="" S DESC=$$GET1^DIQ(FNBR,IEN,FLD,"E")
  1.  .. S II=II+1,@DATA@(II)=IEN_"^"_TEXT_"^"_DESC_$C(30)
  1.  . I MAP'="" D
  1.  .. S II=II+1,@DATA@(II)=^TMP("DILIST",$J,JJ,0)_$C(30)
  1.  ;
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ERR ;
  1.  D ^%ZTER
  1.  NEW Y,ERRDTM
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1.  S BMXSEC="Recording that an error occurred at "_ERRDTM
  1.  I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. CHK(BFLD) ;EP - Check for definition of a field
  1.  NEW DLEN
  1.  D FIELD^DID(FNBR,BFLD,"","TYPE","BQX")
  1.  D FIELD^DID(FNBR,BFLD,"","FIELD LENGTH","BQX")
  1.  D FIELD^DID(FNBR,BFLD,"","LABEL","BQX")
  1.  S TYPE=$S(BQX("TYPE")["DATE":"D",1:"T")
  1.  S DLEN=BQX("FIELD LENGTH")
  1.  S TYPE=TYPE_$E("00000",$L(DLEN)+1,5)_DLEN_BQX("LABEL")
  1.  K BQX
  1.  Q