BTPWPQVW ;VNGT/HS/ALA-CMET Queue User View ; 16 Jun 2009 4:49 PM
;;1.0;CARE MANAGEMENT EVENT TRACKING;**2,3**;Feb 07, 2011;Build 63
;
;
RET(DATA,FAKE) ; EP -- BTPW GET CMET PREFS
;Description
; Retrieve the queue preferences for an owner
;
;Input
; FAKE - extra 'blank' parameter required by BMXNET async 'feature'
;Output
; DATA - name of global (passed by reference) in which the data
; is stored
;Assumes
; DUZ - User who signed onto iCare
;
NEW UID,II,X,MIEN,SOURCE,PARMS,PIEN,NAME,PTYP,VALUE,PMIEN
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BTPWPQVW",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BTPWPQVW D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(II)="T00001TYPE^T03200PARMS"_$C(30)
;
S MIEN=0,PARMS=""
; if no defined user preference, set the default values
;
;Events
F TYPE="Q" D
. S MIEN=$O(^BQICARE(DUZ,9,"B",TYPE,""))
. I MIEN="" D
.. S PARMS="STATUS=P"_$C(28)_"TMFRAME=T-3M"
.. S PARMS=$$DCAT(PARMS) ;Add CAT values, if needed
.. S II=II+1,@DATA@(II)=TYPE_"^"_PARMS_$C(30)
. I MIEN'="" D GET(TYPE,MIEN)
;
;Tracked
S MIEN=0,PARMS=""
F TYPE="T" D
. S MIEN=$O(^BQICARE(DUZ,9,"B",TYPE,""))
. I MIEN="" D
.. S PARMS="STATE=O"_$C(28)_"TMFRAME=T-12M"
.. S PARMS=$$DCAT(PARMS) ;Add CAT values, if needed
.. S II=II+1,@DATA@(II)=TYPE_"^"_PARMS_$C(30)
. I MIEN'="" D GET(TYPE,MIEN)
;
;Followup
S MIEN=0,PARMS=""
F TYPE="P" D
. S MIEN=$O(^BQICARE(DUZ,9,"B",TYPE,""))
. I MIEN="" D
.. ;S PARMS="STATE=F"_$C(28)_"TMFRAME=T-12M"
.. S PARMS="TMFRAME=T+6M"
.. S PARMS=$$DCAT(PARMS) ;Add CAT values, if needed
.. S II=II+1,@DATA@(II)=TYPE_"^"_PARMS_$C(30)
. I MIEN'="" D GET(TYPE,MIEN)
;
;Panel Events
F TYPE="PQ" D
. S MIEN=$O(^BQICARE(DUZ,9,"B",TYPE,""))
. I MIEN="" D
.. S PARMS="STATUS=P"_$C(28)_"TMFRAME=T-3M"
.. S PARMS=$$DCAT(PARMS) ;Add CAT values, if needed
.. S II=II+1,@DATA@(II)=TYPE_"^"_PARMS_$C(30)
. I MIEN'="" D GET(TYPE,MIEN)
;
DONE S II=II+1,@DATA@(II)=$C(31)
Q
;
GET(TYPE,MIEN) ;EP
S PIEN=0,PARMS=""
F S PIEN=$O(^BQICARE(DUZ,9,MIEN,1,PIEN)) Q:'PIEN D
. NEW DA,IENS
. S DA(2)=DUZ,DA(1)=MIEN,DA=PIEN,IENS=$$IENS^DILF(.DA)
. S NAME=$$GET1^DIQ(90505.161,IENS,.01,"E")
. S VALUE=$$GET1^DIQ(90505.161,IENS,.03,"E")
. I VALUE="" S VALUE=$$GET1^DIQ(90505.161,IENS,.02,"E")
. S PARMS=PARMS_$S(PARMS]"":$C(28),1:"")_NAME_"="
. I VALUE'="" S PARMS=PARMS_VALUE Q
. ;
. ; Check for multiple values
. N VALSTR S VALSTR=""
. S PMIEN=0
. F S PMIEN=$O(^BQICARE(DUZ,9,MIEN,1,PIEN,1,PMIEN)) Q:'PMIEN D
.. NEW DA,IENS
.. S DA(3)=DUZ,DA(2)=MIEN,DA(1)=PIEN,DA=PMIEN,IENS=$$IENS^DILF(.DA)
.. S VALUE=$$GET1^DIQ(90505.1611,IENS,.02,"E")
.. I VALUE="" S VALUE=$$GET1^DIQ(90505.1611,IENS,.01,"E")
.. S VALSTR=VALSTR_$S(VALSTR]"":$C(29),1:"")_VALUE
. ;
. ; Tack on Multiple Values
. S PARMS=PARMS_VALSTR
. K VALSTR
. ;
;
S PARMS=$$DCAT(PARMS) ;Add CAT values, if needed
;
S II=II+1,@DATA@(II)=TYPE_"^"_PARMS_$C(30)
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
;
UPD(DATA,TYPE,PARMS) ; EP - BTPW SET CMET PREFS
;
;Input
; TYPE - 'P' for Planned preferences, 'Q' for Queued preferences and 'T' for Tracked preferences
; PARMS - Parameters
;Assumes
; DUZ - User who signed onto iCare
;
NEW UID,II,X,MIEN,PIEN,PMIEN,VALUE,PDATA,ALDA,QFL,BQ,NAME,MVAL,BQII,PPIEN,TYPN,TEMP,LDTM
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BTPWPQVW",UID)),TEMP=$NA(^TMP("TEMP",UID))
K @DATA,@TEMP
;
S II=0,TYPE=$G(TYPE,"")
;
I TYPE="" S BMXSEC="RPC Failed: No Type of Preferences passed in" Q
I $D(PARMS)>10 D
. NEW LIST,BN,BBN
. S LIST="",BN=""
. F S BN=$O(PARMS(BN)) Q:BN="" D
.. I BN=1,PARMS(BN)["COMM=" D
... S @TEMP@(BN)="COMM="_$P(PARMS(BN),"COMM=",2)
... S BBN=BN F S BBN=$O(PARMS(BBN)) Q:BBN="" S @TEMP@(BBN)=PARMS(BBN) K PARMS(BBN)
... S PARMS(BN)=$P(PARMS(BN),"COMM=",1)
.. S LIST=LIST_PARMS(BN)
. K PARMS S PARMS=LIST
;
;I PARMS="" S BMXSEC="RPC Failed: No parameters passed in" Q
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BTPWPQVW D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(II)="I00010RESULT"_$C(30)
;
S TYPN=$O(^BQICARE(DUZ,9,"B",TYPE,""))
; Clean out all the previous parameters
I TYPN'="" D DEL
I TYPN="" D
. NEW DA,DIC
. S DA(1)=DUZ,X=TYPE,DIC(0)="LNZ",DLAYGO=90505.16
. I $G(^BQICARE(DUZ,9,0))="" S ^BQICARE(DUZ,9,0)="^90505.16S^^"
. S DIC="^BQICARE("_DA(1)_",9,"
. D ^DIC S TYPN=+Y I TYPN=-1 K DO,DD D FILE^DICN S TYPN=+Y
;
S QFL=0
F BQ=1:1:$L(PARMS,$C(28)) D G DONE:QFL
. S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
. D NPM(TYPN,NAME,.PDA) I QFL Q
. ;
. NEW DA,IENS
. S DA(2)=DUZ,DA(1)=TYPN,DA=PDA
. S IENS=$$IENS^DILF(.DA)
. I VALUE'[$C(29) D NRC(IENS,VALUE) Q
. ;
. I VALUE[$C(29) D Q:QFL
.. I '$D(^BQICARE(DA(2),9,DA(1),1,PDA,1,0)) S ^BQICARE(DA(2),9,DA(1),1,PDA,1,0)="^90505.1611^^"
.. F BQII=1:1:$L(VALUE,$C(29)) D
... S MVAL=$P(VALUE,$C(29),BQII)
... D NML(TYPN,PDA,MVAL)
;
; Check for community list
I $D(@TEMP)>0 D Q:QFL
. D NPM(TYPN,"COMM",.PDA) I QFL Q
. S DA(2)=DUZ,DA(1)=TYPN,DA=PDA
. I '$D(^BQICARE(DA(2),9,DA(1),1,PDA,1,0)) S ^BQICARE(DA(2),9,DA(1),1,PDA,1,0)="^90505.1611^^"
. NEW BN,LINE,NBN,LSTI,BQII
. S BN="",LINE=""
. F S BN=$O(@TEMP@(BN)) Q:BN="" D
.. S NBN=$O(@TEMP@(BN))
.. S LINE=LINE_@TEMP@(BN) I NBN'="" S LINE=LINE_@TEMP@(NBN)
.. I LINE["COMM=" S LINE=$P(LINE,"COMM=",2)
.. S LSTI=$L(LINE,$C(29))-10
.. F BQII=1:1:LSTI S MVAL=$P(LINE,$C(29),BQII) D NML(TYPN,PDA,MVAL)
.. S LINE=$P(LINE,$C(29),LSTI+1,$L(LINE,$C(29)))
.. I NBN'="" S BN=NBN
. F BQII=1:1 S MVAL=$P(LINE,$C(29),BQII) Q:MVAL="" D NML(TYPN,PDA,MVAL)
;
S II=II+1,@DATA@(II)="1"_$C(30)
S II=II+1,@DATA@(II)=$C(31)
K @TEMP
Q
;
DELA(DATA) ; Delete all CMET User definitions
NEW UID,II,DA,DIK
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BTPWPQVW",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BTPWPQVW D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="I00010RESULT"_$C(30)
S DA(1)=DUZ,DA=0,DIK="^BQICARE("_DA(1)_",9,"
F S DA=$O(^BQICARE(DUZ,9,DA)) Q:'DA D ^DIK
S II=II+1,@DATA@(II)="1"_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
DEL ; Delete the previous User preferences for the Type
NEW DA,DIK
S DA(2)=DUZ,DA(1)=TYPN,DA=0,DIK="^BQICARE("_DA(2)_",9,"_DA(1)_",1,"
F S DA=$O(^BQICARE(DUZ,9,TYPN,1,DA)) Q:'DA D ^DIK
;F S DA=$O(^BQICARE(DUZ,9,DA)) Q:'DA D ^DIK
Q
;
NPM(TYPN,NAME,PDA) ;EP - Add new parameter
NEW DA,IENS,DIC,DLAYGO
S DA(2)=DUZ,DA(1)=TYPN,X=NAME,DIC="^BQICARE("_DA(2)_",9,"_DA(1)_",1,"
I '$D(^BQICARE(DA(2),9,DA(1),1,0)) S ^BQICARE(DA(2),9,DA(1),1,0)="^90505.161^^"
S DLAYGO=90505.161,DIC(0)="L",DIC("P")=DLAYGO
K DO,DD D FILE^DICN
S (DA,PDA)=+Y
I DA=-1 S II=II+1,@DATA@(II)="-1"_$C(30),QFL=1 Q
Q
;
NRC(IENS,VALUE) ;EP - New record
I VALUE?.N S BQIUPD(90505.161,IENS,.03)=VALUE
I VALUE'?.N S BQIUPD(90505.161,IENS,.02)=VALUE
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
Q
;
NML(TYPN,PDA,MVAL) ; EP - New multiple record
NEW DA,IENS
S DA(3)=DUZ,DA(2)=TYPN,DA(1)=PDA,X=MVAL
S DLAYGO=90505.1611,DIC(0)="L",DIC("P")=DLAYGO
S DIC="^BQICARE("_DA(3)_",9,"_DA(2)_",1,"_DA(1)_",1,"
K DO,DD D FILE^DICN
S DA=+Y
I DA=-1 S II=II+1,@DATA@(II)="-1"_$C(30),QFL=1 Q
S IENS=$$IENS^DILF(.DA)
I MVAL?.N S BQIUPD(90505.1611,IENS,.02)=MVAL
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
Q
;
DCAT(PARM) ; Add all categories if not present in return parameters
;
N IEN,VALUE
I PARM["CAT=" G XDCAT
;
S VALUE="",IEN=0 F S IEN=$O(^BTPW(90621.2,IEN)) Q:'IEN D
. N INACTIVE
. S INACTIVE=$$GET1^DIQ(90621.2,IEN_",",.03,"I") Q:INACTIVE=1
. S VALUE=VALUE_$S(VALUE="":"",1:$C(29))_IEN
S PARM=PARM_$S(PARM="":"",1:$C(28))_"CAT="_VALUE
;
XDCAT Q PARM
BTPWPQVW ;VNGT/HS/ALA-CMET Queue User View ; 16 Jun 2009 4:49 PM
+1 ;;1.0;CARE MANAGEMENT EVENT TRACKING;**2,3**;Feb 07, 2011;Build 63
+2 ;
+3 ;
RET(DATA,FAKE) ; EP -- BTPW GET CMET PREFS
+1 ;Description
+2 ; Retrieve the queue preferences for an owner
+3 ;
+4 ;Input
+5 ; FAKE - extra 'blank' parameter required by BMXNET async 'feature'
+6 ;Output
+7 ; DATA - name of global (passed by reference) in which the data
+8 ; is stored
+9 ;Assumes
+10 ; DUZ - User who signed onto iCare
+11 ;
+12 NEW UID,II,X,MIEN,SOURCE,PARMS,PIEN,NAME,PTYP,VALUE,PMIEN
+13 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+14 SET DATA=$NAME(^TMP("BTPWPQVW",UID))
+15 KILL @DATA
+16 ;
+17 SET II=0
+18 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BTPWPQVW D UNWIND^%ZTER"
+19 ;
+20 SET @DATA@(II)="T00001TYPE^T03200PARMS"_$CHAR(30)
+21 ;
+22 SET MIEN=0
SET PARMS=""
+23 ; if no defined user preference, set the default values
+24 ;
+25 ;Events
+26 FOR TYPE="Q"
Begin DoDot:1
+27 SET MIEN=$ORDER(^BQICARE(DUZ,9,"B",TYPE,""))
+28 IF MIEN=""
Begin DoDot:2
+29 SET PARMS="STATUS=P"_$CHAR(28)_"TMFRAME=T-3M"
+30 ;Add CAT values, if needed
SET PARMS=$$DCAT(PARMS)
+31 SET II=II+1
SET @DATA@(II)=TYPE_"^"_PARMS_$CHAR(30)
End DoDot:2
+32 IF MIEN'=""
DO GET(TYPE,MIEN)
End DoDot:1
+33 ;
+34 ;Tracked
+35 SET MIEN=0
SET PARMS=""
+36 FOR TYPE="T"
Begin DoDot:1
+37 SET MIEN=$ORDER(^BQICARE(DUZ,9,"B",TYPE,""))
+38 IF MIEN=""
Begin DoDot:2
+39 SET PARMS="STATE=O"_$CHAR(28)_"TMFRAME=T-12M"
+40 ;Add CAT values, if needed
SET PARMS=$$DCAT(PARMS)
+41 SET II=II+1
SET @DATA@(II)=TYPE_"^"_PARMS_$CHAR(30)
End DoDot:2
+42 IF MIEN'=""
DO GET(TYPE,MIEN)
End DoDot:1
+43 ;
+44 ;Followup
+45 SET MIEN=0
SET PARMS=""
+46 FOR TYPE="P"
Begin DoDot:1
+47 SET MIEN=$ORDER(^BQICARE(DUZ,9,"B",TYPE,""))
+48 IF MIEN=""
Begin DoDot:2
+49 ;S PARMS="STATE=F"_$C(28)_"TMFRAME=T-12M"
+50 SET PARMS="TMFRAME=T+6M"
+51 ;Add CAT values, if needed
SET PARMS=$$DCAT(PARMS)
+52 SET II=II+1
SET @DATA@(II)=TYPE_"^"_PARMS_$CHAR(30)
End DoDot:2
+53 IF MIEN'=""
DO GET(TYPE,MIEN)
End DoDot:1
+54 ;
+55 ;Panel Events
+56 FOR TYPE="PQ"
Begin DoDot:1
+57 SET MIEN=$ORDER(^BQICARE(DUZ,9,"B",TYPE,""))
+58 IF MIEN=""
Begin DoDot:2
+59 SET PARMS="STATUS=P"_$CHAR(28)_"TMFRAME=T-3M"
+60 ;Add CAT values, if needed
SET PARMS=$$DCAT(PARMS)
+61 SET II=II+1
SET @DATA@(II)=TYPE_"^"_PARMS_$CHAR(30)
End DoDot:2
+62 IF MIEN'=""
DO GET(TYPE,MIEN)
End DoDot:1
+63 ;
DONE SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
GET(TYPE,MIEN) ;EP
+1 SET PIEN=0
SET PARMS=""
+2 FOR
SET PIEN=$ORDER(^BQICARE(DUZ,9,MIEN,1,PIEN))
IF 'PIEN
QUIT
Begin DoDot:1
+3 NEW DA,IENS
+4 SET DA(2)=DUZ
SET DA(1)=MIEN
SET DA=PIEN
SET IENS=$$IENS^DILF(.DA)
+5 SET NAME=$$GET1^DIQ(90505.161,IENS,.01,"E")
+6 SET VALUE=$$GET1^DIQ(90505.161,IENS,.03,"E")
+7 IF VALUE=""
SET VALUE=$$GET1^DIQ(90505.161,IENS,.02,"E")
+8 SET PARMS=PARMS_$SELECT(PARMS]"":$CHAR(28),1:"")_NAME_"="
+9 IF VALUE'=""
SET PARMS=PARMS_VALUE
QUIT
+10 ;
+11 ; Check for multiple values
+12 NEW VALSTR
SET VALSTR=""
+13 SET PMIEN=0
+14 FOR
SET PMIEN=$ORDER(^BQICARE(DUZ,9,MIEN,1,PIEN,1,PMIEN))
IF 'PMIEN
QUIT
Begin DoDot:2
+15 NEW DA,IENS
+16 SET DA(3)=DUZ
SET DA(2)=MIEN
SET DA(1)=PIEN
SET DA=PMIEN
SET IENS=$$IENS^DILF(.DA)
+17 SET VALUE=$$GET1^DIQ(90505.1611,IENS,.02,"E")
+18 IF VALUE=""
SET VALUE=$$GET1^DIQ(90505.1611,IENS,.01,"E")
+19 SET VALSTR=VALSTR_$SELECT(VALSTR]"":$CHAR(29),1:"")_VALUE
End DoDot:2
+20 ;
+21 ; Tack on Multiple Values
+22 SET PARMS=PARMS_VALSTR
+23 KILL VALSTR
+24 ;
End DoDot:1
+25 ;
+26 ;Add CAT values, if needed
SET PARMS=$$DCAT(PARMS)
+27 ;
+28 SET II=II+1
SET @DATA@(II)=TYPE_"^"_PARMS_$CHAR(30)
+29 QUIT
+30 ;
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 ;
UPD(DATA,TYPE,PARMS) ; EP - BTPW SET CMET PREFS
+1 ;
+2 ;Input
+3 ; TYPE - 'P' for Planned preferences, 'Q' for Queued preferences and 'T' for Tracked preferences
+4 ; PARMS - Parameters
+5 ;Assumes
+6 ; DUZ - User who signed onto iCare
+7 ;
+8 NEW UID,II,X,MIEN,PIEN,PMIEN,VALUE,PDATA,ALDA,QFL,BQ,NAME,MVAL,BQII,PPIEN,TYPN,TEMP,LDTM
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("BTPWPQVW",UID))
SET TEMP=$NAME(^TMP("TEMP",UID))
+11 KILL @DATA,@TEMP
+12 ;
+13 SET II=0
SET TYPE=$GET(TYPE,"")
+14 ;
+15 IF TYPE=""
SET BMXSEC="RPC Failed: No Type of Preferences passed in"
QUIT
+16 IF $DATA(PARMS)>10
Begin DoDot:1
+17 NEW LIST,BN,BBN
+18 SET LIST=""
SET BN=""
+19 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
Begin DoDot:2
+20 IF BN=1
IF PARMS(BN)["COMM="
Begin DoDot:3
+21 SET @TEMP@(BN)="COMM="_$PIECE(PARMS(BN),"COMM=",2)
+22 SET BBN=BN
FOR
SET BBN=$ORDER(PARMS(BBN))
IF BBN=""
QUIT
SET @TEMP@(BBN)=PARMS(BBN)
KILL PARMS(BBN)
+23 SET PARMS(BN)=$PIECE(PARMS(BN),"COMM=",1)
End DoDot:3
+24 SET LIST=LIST_PARMS(BN)
End DoDot:2
+25 KILL PARMS
SET PARMS=LIST
End DoDot:1
+26 ;
+27 ;I PARMS="" S BMXSEC="RPC Failed: No parameters passed in" Q
+28 ;
+29 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BTPWPQVW D UNWIND^%ZTER"
+30 ;
+31 SET @DATA@(II)="I00010RESULT"_$CHAR(30)
+32 ;
+33 SET TYPN=$ORDER(^BQICARE(DUZ,9,"B",TYPE,""))
+34 ; Clean out all the previous parameters
+35 IF TYPN'=""
DO DEL
+36 IF TYPN=""
Begin DoDot:1
+37 NEW DA,DIC
+38 SET DA(1)=DUZ
SET X=TYPE
SET DIC(0)="LNZ"
SET DLAYGO=90505.16
+39 IF $GET(^BQICARE(DUZ,9,0))=""
SET ^BQICARE(DUZ,9,0)="^90505.16S^^"
+40 SET DIC="^BQICARE("_DA(1)_",9,"
+41 DO ^DIC
SET TYPN=+Y
IF TYPN=-1
KILL DO,DD
DO FILE^DICN
SET TYPN=+Y
End DoDot:1
+42 ;
+43 SET QFL=0
+44 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+45 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+46 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+47 DO NPM(TYPN,NAME,.PDA)
IF QFL
QUIT
+48 ;
+49 NEW DA,IENS
+50 SET DA(2)=DUZ
SET DA(1)=TYPN
SET DA=PDA
+51 SET IENS=$$IENS^DILF(.DA)
+52 IF VALUE'[$CHAR(29)
DO NRC(IENS,VALUE)
QUIT
+53 ;
+54 IF VALUE[$CHAR(29)
Begin DoDot:2
+55 IF '$DATA(^BQICARE(DA(2),9,DA(1),1,PDA,1,0))
SET ^BQICARE(DA(2),9,DA(1),1,PDA,1,0)="^90505.1611^^"
+56 FOR BQII=1:1:$LENGTH(VALUE,$CHAR(29))
Begin DoDot:3
+57 SET MVAL=$PIECE(VALUE,$CHAR(29),BQII)
+58 DO NML(TYPN,PDA,MVAL)
End DoDot:3
End DoDot:2
IF QFL
QUIT
End DoDot:1
IF QFL
GOTO DONE
+59 ;
+60 ; Check for community list
+61 IF $DATA(@TEMP)>0
Begin DoDot:1
+62 DO NPM(TYPN,"COMM",.PDA)
IF QFL
QUIT
+63 SET DA(2)=DUZ
SET DA(1)=TYPN
SET DA=PDA
+64 IF '$DATA(^BQICARE(DA(2),9,DA(1),1,PDA,1,0))
SET ^BQICARE(DA(2),9,DA(1),1,PDA,1,0)="^90505.1611^^"
+65 NEW BN,LINE,NBN,LSTI,BQII
+66 SET BN=""
SET LINE=""
+67 FOR
SET BN=$ORDER(@TEMP@(BN))
IF BN=""
QUIT
Begin DoDot:2
+68 SET NBN=$ORDER(@TEMP@(BN))
+69 SET LINE=LINE_@TEMP@(BN)
IF NBN'=""
SET LINE=LINE_@TEMP@(NBN)
+70 IF LINE["COMM="
SET LINE=$PIECE(LINE,"COMM=",2)
+71 SET LSTI=$LENGTH(LINE,$CHAR(29))-10
+72 FOR BQII=1:1:LSTI
SET MVAL=$PIECE(LINE,$CHAR(29),BQII)
DO NML(TYPN,PDA,MVAL)
+73 SET LINE=$PIECE(LINE,$CHAR(29),LSTI+1,$LENGTH(LINE,$CHAR(29)))
+74 IF NBN'=""
SET BN=NBN
End DoDot:2
+75 FOR BQII=1:1
SET MVAL=$PIECE(LINE,$CHAR(29),BQII)
IF MVAL=""
QUIT
DO NML(TYPN,PDA,MVAL)
End DoDot:1
IF QFL
QUIT
+76 ;
+77 SET II=II+1
SET @DATA@(II)="1"_$CHAR(30)
+78 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+79 KILL @TEMP
+80 QUIT
+81 ;
DELA(DATA) ; Delete all CMET User definitions
+1 NEW UID,II,DA,DIK
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BTPWPQVW",UID))
+4 KILL @DATA
+5 ;
+6 SET II=0
+7 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BTPWPQVW D UNWIND^%ZTER"
+8 SET @DATA@(II)="I00010RESULT"_$CHAR(30)
+9 SET DA(1)=DUZ
SET DA=0
SET DIK="^BQICARE("_DA(1)_",9,"
+10 FOR
SET DA=$ORDER(^BQICARE(DUZ,9,DA))
IF 'DA
QUIT
DO ^DIK
+11 SET II=II+1
SET @DATA@(II)="1"_$CHAR(30)
+12 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+13 QUIT
+14 ;
DEL ; Delete the previous User preferences for the Type
+1 NEW DA,DIK
+2 SET DA(2)=DUZ
SET DA(1)=TYPN
SET DA=0
SET DIK="^BQICARE("_DA(2)_",9,"_DA(1)_",1,"
+3 FOR
SET DA=$ORDER(^BQICARE(DUZ,9,TYPN,1,DA))
IF 'DA
QUIT
DO ^DIK
+4 ;F S DA=$O(^BQICARE(DUZ,9,DA)) Q:'DA D ^DIK
+5 QUIT
+6 ;
NPM(TYPN,NAME,PDA) ;EP - Add new parameter
+1 NEW DA,IENS,DIC,DLAYGO
+2 SET DA(2)=DUZ
SET DA(1)=TYPN
SET X=NAME
SET DIC="^BQICARE("_DA(2)_",9,"_DA(1)_",1,"
+3 IF '$DATA(^BQICARE(DA(2),9,DA(1),1,0))
SET ^BQICARE(DA(2),9,DA(1),1,0)="^90505.161^^"
+4 SET DLAYGO=90505.161
SET DIC(0)="L"
SET DIC("P")=DLAYGO
+5 KILL DO,DD
DO FILE^DICN
+6 SET (DA,PDA)=+Y
+7 IF DA=-1
SET II=II+1
SET @DATA@(II)="-1"_$CHAR(30)
SET QFL=1
QUIT
+8 QUIT
+9 ;
NRC(IENS,VALUE) ;EP - New record
+1 IF VALUE?.N
SET BQIUPD(90505.161,IENS,.03)=VALUE
+2 IF VALUE'?.N
SET BQIUPD(90505.161,IENS,.02)=VALUE
+3 DO FILE^DIE("","BQIUPD","ERROR")
+4 KILL BQIUPD
+5 QUIT
+6 ;
NML(TYPN,PDA,MVAL) ; EP - New multiple record
+1 NEW DA,IENS
+2 SET DA(3)=DUZ
SET DA(2)=TYPN
SET DA(1)=PDA
SET X=MVAL
+3 SET DLAYGO=90505.1611
SET DIC(0)="L"
SET DIC("P")=DLAYGO
+4 SET DIC="^BQICARE("_DA(3)_",9,"_DA(2)_",1,"_DA(1)_",1,"
+5 KILL DO,DD
DO FILE^DICN
+6 SET DA=+Y
+7 IF DA=-1
SET II=II+1
SET @DATA@(II)="-1"_$CHAR(30)
SET QFL=1
QUIT
+8 SET IENS=$$IENS^DILF(.DA)
+9 IF MVAL?.N
SET BQIUPD(90505.1611,IENS,.02)=MVAL
+10 DO FILE^DIE("","BQIUPD","ERROR")
+11 KILL BQIUPD
+12 QUIT
+13 ;
DCAT(PARM) ; Add all categories if not present in return parameters
+1 ;
+2 NEW IEN,VALUE
+3 IF PARM["CAT="
GOTO XDCAT
+4 ;
+5 SET VALUE=""
SET IEN=0
FOR
SET IEN=$ORDER(^BTPW(90621.2,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+6 NEW INACTIVE
+7 SET INACTIVE=$$GET1^DIQ(90621.2,IEN_",",.03,"I")
IF INACTIVE=1
QUIT
+8 SET VALUE=VALUE_$SELECT(VALUE="":"",1:$CHAR(29))_IEN
End DoDot:1
+9 SET PARM=PARM_$SELECT(PARM="":"",1:$CHAR(28))_"CAT="_VALUE
+10 ;
XDCAT QUIT PARM
