BQITAXX2 ;PRXM/HC/ALA - Add Taxonomy Item ; 26 May 2006 2:00 PM
;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
;
Q
;
ADD(DATA,TVALUE,LOW,HIGH) ;EP -- BQI ADD TAXONOMY ITEM
;
;Input
; TVALUE - Taxonomy pointer
; LOW - Low value
; HIGH - High value
;
NEW UID,II,X
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQITXADD",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQITAXX2 D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
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
;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
;
S TVALUE=$G(TVALUE,""),LOW=$G(LOW,""),HIGH=$G(HIGH,"")
I TVALUE="" S BMXSEC="No taxonomy identified" Q
I LOW="" S BMXSEC="No LOW value submitted" Q
;
S @DATA@(II)="I00010RESULT"_$C(30)
;
NEW FILE,SBFILE,DA,DIC,Y,RESULT,BQIUPD,CANON,IEN
S FILE=$$GREF^BQITAXX(TVALUE),IEN=$P(TVALUE,";",1),CANON=0
I FILE=9002226 S SBFILE=FILE_".02101",CANON=$$GET1^DIQ(FILE,IEN_",",.13,"I")
I FILE=9002228 S SBFILE=FILE_".04101"
I CANON D
. I LOW["."!($E(LOW,1,1)="0")!($E(LOW,$L(LOW),$L(LOW))=0) S LOW=LOW_" "
. I HIGH["."!($E(HIGH,1,1)="0")!($E(HIGH,$L(HIGH),$L(HIGH))=0) S HIGH=HIGH_" "
;
S DA(1)=$P(TVALUE,";",1),DIC="^"_$P(TVALUE,";",2)_DA(1)_",21,"
S DIC(0)="L",X=LOW
K DO,DD D FILE^DICN
I Y<1 S RESULT=-1
I +Y>0 S RESULT=1,DA=+Y D
. NEW IENS
. S IENS=$$IENS^DILF(.DA)
. S BQIUPD(SBFILE,IENS,.02)=$S(HIGH'="":HIGH,1:LOW)
. I FILE=9002228 D ; Updated by/date are unique to ^ATXLAB
.. S BQIUPD(FILE,DA(1)_",",.05)=DUZ
.. S BQIUPD(FILE,DA(1)_",",.06)=DT
. D FILE^DIE("","BQIUPD","ERROR")
. K BQIUPD
S II=II+1,@DATA@(II)=RESULT_$C(30)
Q
;
LKP(DATA,TVALUE,FNBR,VALUE) ;EP -- BQI LOOKUP TAXONOMY ITEM
;
;Input
; TVALUE - Taxonomy pointer
; FNBR - File number to look up value
; VALUE - Value to look up in File number
;
NEW UID,II,X
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQITXLKP",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQITAXX2 D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S FNBR=$G(FNBR,""),VALUE=$G(VALUE,""),TVALUE=$G(TVALUE,"")
I TVALUE="" S BMXSEC="No taxonomy identified" Q
I VALUE="" S BMXSEC="No value to look up" Q
;
; if there were no values in the taxonomy before, there may not be
; a file number passed so determine it from taxonomy
I FNBR="" D
. NEW IEN,FILE,ROOT,FLD
. S IEN=$P(TVALUE,";",1),FILE=$$GREF^BQITAXX(TVALUE),ROOT=$$ROOT^DILFD(FILE,"",1)
. I FILE=9002226 S FLD=".15"
. I FILE=9002228 S FLD=".09"
. S FNBR=$$GET1^DIQ(FILE,IEN,FLD,"I")
I FNBR="" S BMXSEC="No file identified to search for value" Q
;
NEW FILE,FIELD,XREF,FLAGS,NUMB,SCREEN,JJ,IEN,TEXT,DESC
NEW MAP,HDR,MII,NFLD,TYPE,VERSION
S FILE=FNBR,XREF="",NUMB="*",SCREEN="",VERSION=$$VERSION^XPDUTL("PSS")
;S FIELD=".01"
S FIELD="FID;-WID"
I FNBR=50,VERSION'="" S FIELD=FIELD_";31"
I FNBR=50,VERSION="" S FIELD=".01"
;S FLAGS=$S(FILE=95.3:"P",1:"MP")
S FLAGS="MP"
D FIND^DIC(FILE,"",FIELD,FLAGS,VALUE,"",XREF,SCREEN,"","","ERROR")
;
S MAP=$G(^TMP("DILIST",$J,0,"MAP"))
I FNBR=50,VERSION="" S MAP="IEN^.01I^100^31"
I MAP="" S @DATA@(II)="I00010IEN^T00030TEXT^T00120DESCRIPTION"_$C(30)
I MAP'="" D
. S HDR=""
. F MII=1:1:$L(MAP,"^") D
.. I $P(MAP,"^",MII)="IEN" S HDR=HDR_"I00010IEN^" Q
.. I $P(MAP,"^",MII)[".01" D CHK(.01) S HDR=HDR_TYPE_"^" Q
.. S NFLD=$P(MAP,"^",MII)
.. I NFLD["FID(" S NFLD=$P($P(NFLD,"FID(",2),")",1) D CHK(NFLD) S HDR=HDR_TYPE_"^" Q
.. D CHK(NFLD) S HDR=HDR_TYPE_"^"
. S HDR=$$TKO^BQIUL1(HDR,"^")
. I FNBR=9999999.05 F MII=1:1:$L(HDR,"^") D
.. I $P(HDR,"^",MII)="T00003CODE" S $P(HDR,"^",MII)="T00003COMM_CODE"
.. I $P(HDR,"^",MII)="T00030NAME" S $P(HDR,"^",MII)="T00030COMM_NAME"
. S @DATA@(II)=HDR_$C(30)
S JJ=0
F S JJ=$O(^TMP("DILIST",$J,JJ)) Q:'JJ D
. I MAP="" D
.. S IEN=$P(^TMP("DILIST",$J,JJ,0),U,1)
.. S TEXT=$P(^TMP("DILIST",$J,JJ,0),U,2)
.. S DESC=""
.. S FLD=$S(FNBR=80:3,FNBR=80.1:4,FNBR=81:2,FNBR=9999999.31:.02,1:"")
.. I FLD'="" S DESC=$$GET1^DIQ(FNBR,IEN,FLD,"E")
.. S II=II+1,@DATA@(II)=IEN_"^"_TEXT_"^"_DESC_$C(30)
. I MAP'="" D
.. S II=II+1,@DATA@(II)=^TMP("DILIST",$J,JJ,0)_$C(30)
;
S II=II+1,@DATA@(II)=$C(31)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
;
CHK(BFLD) ;EP - Check for definition of a field
NEW DLEN
D FIELD^DID(FNBR,BFLD,"","TYPE","BQX")
D FIELD^DID(FNBR,BFLD,"","FIELD LENGTH","BQX")
D FIELD^DID(FNBR,BFLD,"","LABEL","BQX")
S TYPE=$S(BQX("TYPE")["DATE":"D",1:"T")
S DLEN=BQX("FIELD LENGTH")
S TYPE=TYPE_$E("00000",$L(DLEN)+1,5)_DLEN_BQX("LABEL")
K BQX
Q
BQITAXX2 ;PRXM/HC/ALA - Add Taxonomy Item ; 26 May 2006 2:00 PM
+1 ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
+3 QUIT
+4 ;
ADD(DATA,TVALUE,LOW,HIGH) ;EP -- BQI ADD TAXONOMY ITEM
+1 ;
+2 ;Input
+3 ; TVALUE - Taxonomy pointer
+4 ; LOW - Low value
+5 ; HIGH - High value
+6 ;
+7 NEW UID,II,X
+8 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+9 SET DATA=$NAME(^TMP("BQITXADD",UID))
+10 KILL @DATA
+11 ;
+12 SET II=0
+13 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQITAXX2 D UNWIND^%ZTER"
+14 ;
+15 IF '$$KEYCHK^BQIULSC("BQIZTXED",DUZ)
SET BMXSEC="You do not have the security access to edit a taxonomy."_$CHAR(10)_"Please see your supervisor or program manager."
QUIT
+16 ;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
+17 ;
+18 SET TVALUE=$GET(TVALUE,"")
SET LOW=$GET(LOW,"")
SET HIGH=$GET(HIGH,"")
+19 IF TVALUE=""
SET BMXSEC="No taxonomy identified"
QUIT
+20 IF LOW=""
SET BMXSEC="No LOW value submitted"
QUIT
+21 ;
+22 SET @DATA@(II)="I00010RESULT"_$CHAR(30)
+23 ;
+24 NEW FILE,SBFILE,DA,DIC,Y,RESULT,BQIUPD,CANON,IEN
+25 SET FILE=$$GREF^BQITAXX(TVALUE)
SET IEN=$PIECE(TVALUE,";",1)
SET CANON=0
+26 IF FILE=9002226
SET SBFILE=FILE_".02101"
SET CANON=$$GET1^DIQ(FILE,IEN_",",.13,"I")
+27 IF FILE=9002228
SET SBFILE=FILE_".04101"
+28 IF CANON
Begin DoDot:1
+29 IF LOW["."!($EXTRACT(LOW,1,1)="0")!($EXTRACT(LOW,$LENGTH(LOW),$LENGTH(LOW))=0)
SET LOW=LOW_" "
+30 IF HIGH["."!($EXTRACT(HIGH,1,1)="0")!($EXTRACT(HIGH,$LENGTH(HIGH),$LENGTH(HIGH))=0)
SET HIGH=HIGH_" "
End DoDot:1
+31 ;
+32 SET DA(1)=$PIECE(TVALUE,";",1)
SET DIC="^"_$PIECE(TVALUE,";",2)_DA(1)_",21,"
+33 SET DIC(0)="L"
SET X=LOW
+34 KILL DO,DD
DO FILE^DICN
+35 IF Y<1
SET RESULT=-1
+36 IF +Y>0
SET RESULT=1
SET DA=+Y
Begin DoDot:1
+37 NEW IENS
+38 SET IENS=$$IENS^DILF(.DA)
+39 SET BQIUPD(SBFILE,IENS,.02)=$SELECT(HIGH'="":HIGH,1:LOW)
+40 ; Updated by/date are unique to ^ATXLAB
IF FILE=9002228
Begin DoDot:2
+41 SET BQIUPD(FILE,DA(1)_",",.05)=DUZ
+42 SET BQIUPD(FILE,DA(1)_",",.06)=DT
End DoDot:2
+43 DO FILE^DIE("","BQIUPD","ERROR")
+44 KILL BQIUPD
End DoDot:1
+45 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+46 QUIT
+47 ;
LKP(DATA,TVALUE,FNBR,VALUE) ;EP -- BQI LOOKUP TAXONOMY ITEM
+1 ;
+2 ;Input
+3 ; TVALUE - Taxonomy pointer
+4 ; FNBR - File number to look up value
+5 ; VALUE - Value to look up in File number
+6 ;
+7 NEW UID,II,X
+8 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+9 SET DATA=$NAME(^TMP("BQITXLKP",UID))
+10 KILL @DATA
+11 ;
+12 SET II=0
+13 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQITAXX2 D UNWIND^%ZTER"
+14 ;
+15 SET FNBR=$GET(FNBR,"")
SET VALUE=$GET(VALUE,"")
SET TVALUE=$GET(TVALUE,"")
+16 IF TVALUE=""
SET BMXSEC="No taxonomy identified"
QUIT
+17 IF VALUE=""
SET BMXSEC="No value to look up"
QUIT
+18 ;
+19 ; if there were no values in the taxonomy before, there may not be
+20 ; a file number passed so determine it from taxonomy
+21 IF FNBR=""
Begin DoDot:1
+22 NEW IEN,FILE,ROOT,FLD
+23 SET IEN=$PIECE(TVALUE,";",1)
SET FILE=$$GREF^BQITAXX(TVALUE)
SET ROOT=$$ROOT^DILFD(FILE,"",1)
+24 IF FILE=9002226
SET FLD=".15"
+25 IF FILE=9002228
SET FLD=".09"
+26 SET FNBR=$$GET1^DIQ(FILE,IEN,FLD,"I")
End DoDot:1
+27 IF FNBR=""
SET BMXSEC="No file identified to search for value"
QUIT
+28 ;
+29 NEW FILE,FIELD,XREF,FLAGS,NUMB,SCREEN,JJ,IEN,TEXT,DESC
+30 NEW MAP,HDR,MII,NFLD,TYPE,VERSION
+31 SET FILE=FNBR
SET XREF=""
SET NUMB="*"
SET SCREEN=""
SET VERSION=$$VERSION^XPDUTL("PSS")
+32 ;S FIELD=".01"
+33 SET FIELD="FID;-WID"
+34 IF FNBR=50
IF VERSION'=""
SET FIELD=FIELD_";31"
+35 IF FNBR=50
IF VERSION=""
SET FIELD=".01"
+36 ;S FLAGS=$S(FILE=95.3:"P",1:"MP")
+37 SET FLAGS="MP"
+38 DO FIND^DIC(FILE,"",FIELD,FLAGS,VALUE,"",XREF,SCREEN,"","","ERROR")
+39 ;
+40 SET MAP=$GET(^TMP("DILIST",$JOB,0,"MAP"))
+41 IF FNBR=50
IF VERSION=""
SET MAP="IEN^.01I^100^31"
+42 IF MAP=""
SET @DATA@(II)="I00010IEN^T00030TEXT^T00120DESCRIPTION"_$CHAR(30)
+43 IF MAP'=""
Begin DoDot:1
+44 SET HDR=""
+45 FOR MII=1:1:$LENGTH(MAP,"^")
Begin DoDot:2
+46 IF $PIECE(MAP,"^",MII)="IEN"
SET HDR=HDR_"I00010IEN^"
QUIT
+47 IF $PIECE(MAP,"^",MII)[".01"
DO CHK(.01)
SET HDR=HDR_TYPE_"^"
QUIT
+48 SET NFLD=$PIECE(MAP,"^",MII)
+49 IF NFLD["FID("
SET NFLD=$PIECE($PIECE(NFLD,"FID(",2),")",1)
DO CHK(NFLD)
SET HDR=HDR_TYPE_"^"
QUIT
+50 DO CHK(NFLD)
SET HDR=HDR_TYPE_"^"
End DoDot:2
+51 SET HDR=$$TKO^BQIUL1(HDR,"^")
+52 IF FNBR=9999999.05
FOR MII=1:1:$LENGTH(HDR,"^")
Begin DoDot:2
+53 IF $PIECE(HDR,"^",MII)="T00003CODE"
SET $PIECE(HDR,"^",MII)="T00003COMM_CODE"
+54 IF $PIECE(HDR,"^",MII)="T00030NAME"
SET $PIECE(HDR,"^",MII)="T00030COMM_NAME"
End DoDot:2
+55 SET @DATA@(II)=HDR_$CHAR(30)
End DoDot:1
+56 SET JJ=0
+57 FOR
SET JJ=$ORDER(^TMP("DILIST",$JOB,JJ))
IF 'JJ
QUIT
Begin DoDot:1
+58 IF MAP=""
Begin DoDot:2
+59 SET IEN=$PIECE(^TMP("DILIST",$JOB,JJ,0),U,1)
+60 SET TEXT=$PIECE(^TMP("DILIST",$JOB,JJ,0),U,2)
+61 SET DESC=""
+62 SET FLD=$SELECT(FNBR=80:3,FNBR=80.1:4,FNBR=81:2,FNBR=9999999.31:.02,1:"")
+63 IF FLD'=""
SET DESC=$$GET1^DIQ(FNBR,IEN,FLD,"E")
+64 SET II=II+1
SET @DATA@(II)=IEN_"^"_TEXT_"^"_DESC_$CHAR(30)
End DoDot:2
+65 IF MAP'=""
Begin DoDot:2
+66 SET II=II+1
SET @DATA@(II)=^TMP("DILIST",$JOB,JJ,0)_$CHAR(30)
End DoDot:2
End DoDot:1
+67 ;
+68 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+69 QUIT
+70 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 QUIT
+7 ;
CHK(BFLD) ;EP - Check for definition of a field
+1 NEW DLEN
+2 DO FIELD^DID(FNBR,BFLD,"","TYPE","BQX")
+3 DO FIELD^DID(FNBR,BFLD,"","FIELD LENGTH","BQX")
+4 DO FIELD^DID(FNBR,BFLD,"","LABEL","BQX")
+5 SET TYPE=$SELECT(BQX("TYPE")["DATE":"D",1:"T")
+6 SET DLEN=BQX("FIELD LENGTH")
+7 SET TYPE=TYPE_$EXTRACT("00000",$LENGTH(DLEN)+1,5)_DLEN_BQX("LABEL")
+8 KILL BQX
+9 QUIT
