BQIPLCTX ;VNGT/HS/ALA-Create Community Taxonomy ; 13 Feb 2009 4:59 PM
;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
;
UPD(DATA,PARMS) ; EP -- BQI UPDATE COMM TAXONOMY
NEW UID,II,BQICOMM
NEW ATXFLG,BCOM,BI,BN,BQ,BQFIL,BQFLD,BQIDATA,BQJ,BQN,BQQI,DFIELD,DFILE,ERROR
NEW IEN,LINK,NAME,PDATA,PFIEN,PTYP,RESULT,VALUE,VFIEN,X,Y
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPLCTX",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPLCTX D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="I00010RESULT^T01024MSG^I00010CTXIEN"_$C(30)
;
S PARMS=$G(PARMS,"")
I PARMS="" D
. S LIST="",BN=""
. F S BN=$O(PARMS(BN)) Q:BN="" S LIST=LIST_PARMS(BN)
. K PARMS
. S PARMS=LIST
. K LIST
;
S VFIEN=$O(^BQI(90506.3,"B","Community Taxonomy",""))
I VFIEN="" S BMXSEC="RPC Call Failed: Community Taxonomy does not exist." Q
S DFILE=$P(^BQI(90506.3,VFIEN,0),U,2)
S LINK=$O(^AMQQ(1,"B","PATIENT;CURRENT COMMUNITY",""))
K BQWP
F BQ=1:1:$L(PARMS,$C(28)) D
. S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
. I VALUE="" S VALUE="@"
. S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
. S PTYP=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
. S DFIELD=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
. I PTYP="D",VALUE'="@" S VALUE=$$DATE^BQIUL1(VALUE)
. I PTYP="W" D Q
.. I VALUE="@" S BQIDATA(DFILE,DFIELD)=VALUE Q
.. F BQQI=1:1 S BQJ=$P(VALUE,$C(10),BQQI) Q:BQJ="" D
... S BQWP(DFILE,DFIELD,BQQI)=BQJ
. I NAME="AMQQCOMM",VALUE[$C(29) D Q
.. F BI=1:1:$L(VALUE,$C(29)) D
... S BCOM=$P(VALUE,$C(29),BI) I BCOM="" Q
... I BCOM?.N S BCOM=$P($G(^AUTTCOM(BCOM,0)),U,1) I BCOM="" Q
... S BQICOMM(9002226.02101,BCOM)=""
. I DFIELD'=".01" S BQIDATA(DFILE,DFIELD)=VALUE
. I DFIELD=".01" S X=VALUE
;
S ATXFLG="",DIC="^ATXAX(",DIC(0)="QLX",DLAYGO=9002226
D ^DIC K DIC,DLAYGO
I Y=-1 K DO,DD D FILE^DICN
S IEN=+Y
S BQIUPD(DFILE,IEN_",",.05)=DUZ,BQIUPD(DFILE,IEN_",",.08)=0
S BQIUPD(DFILE,IEN_",",.09)=DT,BQIUPD(DFILE,IEN_",",.12)=LINK
S BQIUPD(DFILE,IEN_",",.13)=0,BQIUPD(DFILE,IEN_",",.15)=9999999.05
D SAV(.BQIUPD,IEN_",")
D FILE^DIE("","BQIUPD","ERROR")
;
I $G(^ATXAX(IEN,21,0))="" S ^ATXAX(IEN,21,0)="^9002226.02101^^"
NEW DA,DIK
S DA(1)=IEN,DIK="^ATXAX("_DA(1)_",21,",DA=0
F S DA=$O(^ATXAX(IEN,21,DA)) Q:'DA D
. S BCOM=$P($G(^ATXAX(IEN,21,DA,0)),U) I BCOM]"" K ^ATXAX(IEN,21,"AA",BCOM,BCOM)
. D ^DIK
;
S BCOM="",DIC(0)="QL",DLAYGO=9002226.02101,DIC="^ATXAX("_DA(1)_",21,"
F S BCOM=$O(BQICOMM(9002226.02101,BCOM)) Q:BCOM="" D
. S X=BCOM
. K DO,DD D FILE^DICN
. S ^ATXAX(IEN,21,"AA",BCOM,BCOM)=""
;
; Set any extended description
I $D(BQIWP) D WP^DIE(9002226,IEN_",",1101,"","BQIWP","ERROR")
;
I $D(ERROR) S RESULT=-1_U_$G(ERROR("DIERR","1","TEXT","1"))
I '$D(ERROR) D
. S RESULT=1_U_U_IEN
. ; Set taxonomy into list
. D UPD^BQITAXX4($P(^ATXAX(IEN,0),U,1),"","CM",7)
S II=II+1,@DATA@(II)=RESULT_$C(30)
;
DONE ;
S II=II+1,@DATA@(II)=$C(31)
Q
;
SAV(BQIUPD,IENS) ;EP - Set the data
;
K BQIWP
S BQFIL=""
F S BQFIL=$O(BQIDATA(BQFIL)) Q:BQFIL="" D
. S BQFLD=""
. F S BQFLD=$O(BQIDATA(BQFIL,BQFLD)) Q:BQFLD="" D
.. S BQIUPD(BQFIL,IENS,BQFLD)=BQIDATA(BQFIL,BQFLD)
;
I $D(BQWP) D WP(IENS)
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
;
WP(WIENS) ;EP - Set up word-processing array
NEW DIWL,DIWR
K ^UTILITY($J,"W")
S DIWL=1,DIWR=70
S BQFIL=""
F S BQFIL=$O(BQWP(BQFIL)) Q:BQFIL="" D
. S BQFLD=""
. F S BQFLD=$O(BQWP(BQFIL,BQFLD)) Q:BQFLD="" D
.. S BQN=""
.. F S BQN=$O(BQWP(BQFIL,BQFLD,BQN)) Q:BQN="" D
... ;S BQIWP(BQFIL,WIENS,BQFLD,BQN)=BQWP(BQFIL,BQFLD,BQN)
... S X=BQWP(BQFIL,BQFLD,BQN)
... D ^DIWP
;
S BQN=""
F S BQN=$O(^UTILITY($J,"W",1,BQN)) Q:BQN="" S BQIWP(BQN)=^UTILITY($J,"W",1,BQN,0)
K ^UTILITY($J,"W")
Q
BQIPLCTX ;VNGT/HS/ALA-Create Community Taxonomy ; 13 Feb 2009 4:59 PM
+1 ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
UPD(DATA,PARMS) ; EP -- BQI UPDATE COMM TAXONOMY
+1 NEW UID,II,BQICOMM
+2 NEW ATXFLG,BCOM,BI,BN,BQ,BQFIL,BQFLD,BQIDATA,BQJ,BQN,BQQI,DFIELD,DFILE,ERROR
+3 NEW IEN,LINK,NAME,PDATA,PFIEN,PTYP,RESULT,VALUE,VFIEN,X,Y
+4 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+5 SET DATA=$NAME(^TMP("BQIPLCTX",UID))
+6 KILL @DATA
+7 ;
+8 SET II=0
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPLCTX D UNWIND^%ZTER"
+10 SET @DATA@(II)="I00010RESULT^T01024MSG^I00010CTXIEN"_$CHAR(30)
+11 ;
+12 SET PARMS=$GET(PARMS,"")
+13 IF PARMS=""
Begin DoDot:1
+14 SET LIST=""
SET BN=""
+15 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+16 KILL PARMS
+17 SET PARMS=LIST
+18 KILL LIST
End DoDot:1
+19 ;
+20 SET VFIEN=$ORDER(^BQI(90506.3,"B","Community Taxonomy",""))
+21 IF VFIEN=""
SET BMXSEC="RPC Call Failed: Community Taxonomy does not exist."
QUIT
+22 SET DFILE=$PIECE(^BQI(90506.3,VFIEN,0),U,2)
+23 SET LINK=$ORDER(^AMQQ(1,"B","PATIENT;CURRENT COMMUNITY",""))
+24 KILL BQWP
+25 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+26 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+27 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+28 IF VALUE=""
SET VALUE="@"
+29 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
+30 SET PTYP=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
+31 SET DFIELD=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
+32 IF PTYP="D"
IF VALUE'="@"
SET VALUE=$$DATE^BQIUL1(VALUE)
+33 IF PTYP="W"
Begin DoDot:2
+34 IF VALUE="@"
SET BQIDATA(DFILE,DFIELD)=VALUE
QUIT
+35 FOR BQQI=1:1
SET BQJ=$PIECE(VALUE,$CHAR(10),BQQI)
IF BQJ=""
QUIT
Begin DoDot:3
+36 SET BQWP(DFILE,DFIELD,BQQI)=BQJ
End DoDot:3
End DoDot:2
QUIT
+37 IF NAME="AMQQCOMM"
IF VALUE[$CHAR(29)
Begin DoDot:2
+38 FOR BI=1:1:$LENGTH(VALUE,$CHAR(29))
Begin DoDot:3
+39 SET BCOM=$PIECE(VALUE,$CHAR(29),BI)
IF BCOM=""
QUIT
+40 IF BCOM?.N
SET BCOM=$PIECE($GET(^AUTTCOM(BCOM,0)),U,1)
IF BCOM=""
QUIT
+41 SET BQICOMM(9002226.02101,BCOM)=""
End DoDot:3
End DoDot:2
QUIT
+42 IF DFIELD'=".01"
SET BQIDATA(DFILE,DFIELD)=VALUE
+43 IF DFIELD=".01"
SET X=VALUE
End DoDot:1
+44 ;
+45 SET ATXFLG=""
SET DIC="^ATXAX("
SET DIC(0)="QLX"
SET DLAYGO=9002226
+46 DO ^DIC
KILL DIC,DLAYGO
+47 IF Y=-1
KILL DO,DD
DO FILE^DICN
+48 SET IEN=+Y
+49 SET BQIUPD(DFILE,IEN_",",.05)=DUZ
SET BQIUPD(DFILE,IEN_",",.08)=0
+50 SET BQIUPD(DFILE,IEN_",",.09)=DT
SET BQIUPD(DFILE,IEN_",",.12)=LINK
+51 SET BQIUPD(DFILE,IEN_",",.13)=0
SET BQIUPD(DFILE,IEN_",",.15)=9999999.05
+52 DO SAV(.BQIUPD,IEN_",")
+53 DO FILE^DIE("","BQIUPD","ERROR")
+54 ;
+55 IF $GET(^ATXAX(IEN,21,0))=""
SET ^ATXAX(IEN,21,0)="^9002226.02101^^"
+56 NEW DA,DIK
+57 SET DA(1)=IEN
SET DIK="^ATXAX("_DA(1)_",21,"
SET DA=0
+58 FOR
SET DA=$ORDER(^ATXAX(IEN,21,DA))
IF 'DA
QUIT
Begin DoDot:1
+59 SET BCOM=$PIECE($GET(^ATXAX(IEN,21,DA,0)),U)
IF BCOM]""
KILL ^ATXAX(IEN,21,"AA",BCOM,BCOM)
+60 DO ^DIK
End DoDot:1
+61 ;
+62 SET BCOM=""
SET DIC(0)="QL"
SET DLAYGO=9002226.02101
SET DIC="^ATXAX("_DA(1)_",21,"
+63 FOR
SET BCOM=$ORDER(BQICOMM(9002226.02101,BCOM))
IF BCOM=""
QUIT
Begin DoDot:1
+64 SET X=BCOM
+65 KILL DO,DD
DO FILE^DICN
+66 SET ^ATXAX(IEN,21,"AA",BCOM,BCOM)=""
End DoDot:1
+67 ;
+68 ; Set any extended description
+69 IF $DATA(BQIWP)
DO WP^DIE(9002226,IEN_",",1101,"","BQIWP","ERROR")
+70 ;
+71 IF $DATA(ERROR)
SET RESULT=-1_U_$GET(ERROR("DIERR","1","TEXT","1"))
+72 IF '$DATA(ERROR)
Begin DoDot:1
+73 SET RESULT=1_U_U_IEN
+74 ; Set taxonomy into list
+75 DO UPD^BQITAXX4($PIECE(^ATXAX(IEN,0),U,1),"","CM",7)
End DoDot:1
+76 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+77 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
SAV(BQIUPD,IENS) ;EP - Set the data
+1 ;
+2 KILL BQIWP
+3 SET BQFIL=""
+4 FOR
SET BQFIL=$ORDER(BQIDATA(BQFIL))
IF BQFIL=""
QUIT
Begin DoDot:1
+5 SET BQFLD=""
+6 FOR
SET BQFLD=$ORDER(BQIDATA(BQFIL,BQFLD))
IF BQFLD=""
QUIT
Begin DoDot:2
+7 SET BQIUPD(BQFIL,IENS,BQFLD)=BQIDATA(BQFIL,BQFLD)
End DoDot:2
End DoDot:1
+8 ;
+9 IF $DATA(BQWP)
DO WP(IENS)
+10 QUIT
+11 ;
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 ;
WP(WIENS) ;EP - Set up word-processing array
+1 NEW DIWL,DIWR
+2 KILL ^UTILITY($JOB,"W")
+3 SET DIWL=1
SET DIWR=70
+4 SET BQFIL=""
+5 FOR
SET BQFIL=$ORDER(BQWP(BQFIL))
IF BQFIL=""
QUIT
Begin DoDot:1
+6 SET BQFLD=""
+7 FOR
SET BQFLD=$ORDER(BQWP(BQFIL,BQFLD))
IF BQFLD=""
QUIT
Begin DoDot:2
+8 SET BQN=""
+9 FOR
SET BQN=$ORDER(BQWP(BQFIL,BQFLD,BQN))
IF BQN=""
QUIT
Begin DoDot:3
+10 ;S BQIWP(BQFIL,WIENS,BQFLD,BQN)=BQWP(BQFIL,BQFLD,BQN)
+11 SET X=BQWP(BQFIL,BQFLD,BQN)
+12 DO ^DIWP
End DoDot:3
End DoDot:2
End DoDot:1
+13 ;
+14 SET BQN=""
+15 FOR
SET BQN=$ORDER(^UTILITY($JOB,"W",1,BQN))
IF BQN=""
QUIT
SET BQIWP(BQN)=^UTILITY($JOB,"W",1,BQN,0)
+16 KILL ^UTILITY($JOB,"W")
+17 QUIT
