- 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
