BQIPLFLG ;PRXM/HC/ALA-Get "Flags" Definition ; 09 Dec 2005 5:18 PM
;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
;
Q
;
RET(DATA,FAKE) ; EP - BQI GET FLAG PREFS
;
;Description
; Retrieve all the defined "flags" definitions 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("BQIPLFLG",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPLFLG D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(II)="T00030SOURCE_NAME^T03200PARMS"_$C(30)
;
S MIEN=0
F S MIEN=$O(^BQICARE(DUZ,10,MIEN)) Q:'MIEN D
. NEW DA,IENS
. S DA(1)=DUZ,DA=MIEN,IENS=$$IENS^DILF(.DA)
. S SOURCE=$$GET1^DIQ(90505.09,IENS,.01,"E")
. S II=II+1,@DATA@(II)=SOURCE
. S PIEN=0,PARMS=""
. F S PIEN=$O(^BQICARE(DUZ,10,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.1,IENS,.01,"E")
.. S PTYP=$$PTYP^BQIDCDF(SOURCE,NAME)
.. I PTYP="T" S VALUE=$$GET1^DIQ(90505.1,IENS,.03,"E")
.. I PTYP'="T" S VALUE=$$GET1^DIQ(90505.1,IENS,.02,"E")
.. ; if the parameter type is a date, convert to non FileMan date format
.. I PTYP="D" S VALUE=$$FMTMDY^BQIUL1(VALUE)
.. S PARMS=PARMS_NAME_"="
.. ;
.. ; Check for values
.. S PMIEN=0
.. F S PMIEN=$O(^BQICARE(DUZ,10,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)
... I PTYP="T" S VALUE=$$GET1^DIQ(90505.11,IENS,.02,"E")
... I PTYP'="T" S VALUE=$$GET1^DIQ(90505.11,IENS,.01,"E")
... ; if the parameter type is a date, convert to non FileMan date format
... I PTYP="D" S VALUE=$$FMTMDY^BQIUL1(VALUE)
... S PARMS=PARMS_VALUE_$C(29)
.. ; Remove trailing $C(29)
.. S PARMS=$$TKO^BQIUL1(PARMS,$C(29))
.. S PARMS=PARMS_VALUE_$C(28)
. ; Remove trailing $C(28)
. S PARMS=$$TKO^BQIUL1(PARMS,$C(28))
. S $P(@DATA@(II),"^",2)=PARMS_$C(30)
;
DONE 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
;
UPD(DATA,SRCNM,PARMS) ; EP - BQI SET FLAG PREFS
;
;Input
; SRCNM - Source Name of the flag
; PARMS - Parameters for the source
;Assumes
; DUZ - User who signed onto iCare
;
NEW UID,II,X,MIEN,PIEN,PMIEN,VALUE,PDATA,ALDA,QFL,BQ,NAME,MVAL,BQII,PPIEN
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPLFLG",UID))
K @DATA
;
S II=0,PARMS=$G(PARMS,"")
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPLFLG D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S PPIEN=$$PP^BQIDCDF(SRCNM) I PPIEN=-1 S BMXSEC="Source not found." Q
S @DATA@(II)="I00010RESULT"_$C(30)
;
NEW DA,DIC,DLAYGO
S DA(1)=DUZ,X=SRCNM
S DLAYGO=90505.09,DIC(0)="LNXZ"
S DIC="^BQICARE("_DA(1)_",10,"
I '$D(^BQICARE(DA(1),10,0)) S ^BQICARE(DA(1),10,0)="^90505.09P^^"
;K DO,DD D FILE^DICN
D ^DIC
S ALDA=+Y
I ALDA=-1 S II=II+1,@DATA@(II)="-1"_$C(30) G DONE
;
; Clean out all the previous parameters
NEW DA,DIK,PN,PDA
S DA(2)=DUZ,DA(1)=ALDA,DIK="^BQICARE("_DA(2)_",10,"_DA(1)_",1,",PN=0
F S PN=$O(^BQICARE(DA(2),10,DA(1),1,PN)) Q:'PN S DA=PN D ^DIK
;
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)
. S PTYP=$$PTYP^BQIDCDF(SRCNM,NAME)
. NEW DA,IENS,DIC
. S DA(2)=DUZ,DA(1)=ALDA,X=NAME
. S DLAYGO=90505.1,DIC(0)="L",DIC("P")=DLAYGO
. S DIC="^BQICARE("_DA(2)_",10,"_DA(1)_",1,"
. I '$D(^BQICARE(DA(2),10,DA(1),1,0)) S ^BQICARE(DA(2),10,DA(1),1,0)="^90505.1^^"
. 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
. ;
. NEW DA,IENS
. S DA(2)=DUZ,DA(1)=ALDA,DA=PDA
. S IENS=$$IENS^DILF(.DA)
. I VALUE'[$C(29) D Q
.. ; if the parameter type is a date, convert to FileMan date format
.. I PTYP="D" S VALUE=$$DATE^BQIUL1(VALUE)
.. I PTYP="T" S BQIUPD(90505.1,IENS,.03)=VALUE
.. I PTYP'="T" S BQIUPD(90505.1,IENS,.02)=VALUE
.. D FILE^DIE("","BQIUPD","ERROR")
.. K BQIUPD
. ;
. I VALUE[$C(29) D Q:QFL
.. I '$D(^BQICARE(DA(2),10,DA(1),1,DA,1,0)) S ^BQICARE(DA(2),10,DA(1),1,DA,1,0)="^90505.11^^"
.. F BQII=1:1:$L(VALUE,$C(29)) D
... S MVAL=$P(VALUE,$C(29),BQII)
... NEW DA,IENS
... S DA(3)=DUZ,DA(2)=ALDA,DA(1)=PDA,X=MVAL
... S DLAYGO=90505.11,DIC(0)="L",DIC("P")=DLAYGO
... S DIC="^BQICARE("_DA(3)_",10,"_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
... ; if the parameter type is a date, convert to FileMan date format
... I PTYP="D" S MVAL=$$DATE^BQIUL1(MVAL)
... S IENS=$$IENS^DILF(.DA)
... I PTYP="T" S BQIUPD(90505.11,IENS,.02)=MVAL
... D FILE^DIE("","BQIUPD","ERROR")
... K BQIUPD
;
S II=II+1,@DATA@(II)="1"_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
DELA(DATA) ; Delete all flag definitions
NEW UID,II,DA,DIK
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPLFLG",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPLFLG 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)_",10,"
F S DA=$O(^BQICARE(DUZ,10,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 flag definitions
NEW DA,DIK
S DA(1)=DUZ,DA=0,DIK="^BQICARE("_DA(1)_",10,"
F S DA=$O(^BQICARE(DUZ,10,DA)) Q:'DA D ^DIK
Q
;
GPARMS(USR,ADSC,PARMS,MPARMS) ;EP - Get parameters for a user's flag preference
;
;Input
; USR = User/Owner internal entry number
; ADSC = Flag description
;
NEW DA,IENS,DIC,AIEN,SOURCE,PIEN,PTYP,VALUE,PMIEN
S DA(1)=USR,X=ADSC,DIC(0)="XZ",DIC="^BQICARE("_DA(1)_",10,"
D ^DIC
I +Y<1 Q
S (DA,AIEN)=+Y,IENS=$$IENS^DILF(.DA)
S SOURCE=$$GET1^DIQ(90505.09,IENS,.01,"E")
S PIEN=0,PARMS=""
F S PIEN=$O(^BQICARE(USR,10,AIEN,1,PIEN)) Q:'PIEN D
. NEW DA,IENS
. S DA(2)=USR,DA(1)=AIEN,DA=PIEN,IENS=$$IENS^DILF(.DA)
. S NAME=$$GET1^DIQ(90505.1,IENS,.01,"E")
. S PTYP=$$PTYP^BQIDCDF(SOURCE,NAME)
. ; if the parameter type is a table, use the pointer (IEN) value
. I PTYP="T" S VALUE=$$GET1^DIQ(90505.1,IENS,.03,"E")
. ; if the parameter type is not a table, use the free text value
. I PTYP'="T" S VALUE=$$GET1^DIQ(90505.1,IENS,.02,"E")
. ; if the parameter type is a date, convert to FileMan date format
. I PTYP="D" S VALUE=$$DATE^BQIUL1(VALUE)
. S PARMS(NAME)=VALUE
. ;
. ; Check for values
. S PMIEN=0
. F S PMIEN=$O(^BQICARE(USR,10,AIEN,1,PIEN,1,PMIEN)) Q:'PMIEN D
.. NEW DA,IENS
.. S DA(3)=USR,DA(2)=AIEN,DA(1)=PIEN,DA=PMIEN,IENS=$$IENS^DILF(.DA)
.. ;
.. ; if the parameter type is a table, use the pointer (IEN) value
.. I PTYP="T" S VALUE=$$GET1^DIQ(90505.11,IENS,.02,"E")
.. ; if the parameter type is not a table, use the free text value
.. I PTYP'="T" S VALUE=$$GET1^DIQ(90505.11,IENS,.01,"E")
.. S MPARMS(NAME,VALUE)=""
Q
BQIPLFLG ;PRXM/HC/ALA-Get "Flags" Definition ; 09 Dec 2005 5:18 PM
+1 ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
+3 QUIT
+4 ;
RET(DATA,FAKE) ; EP - BQI GET FLAG PREFS
+1 ;
+2 ;Description
+3 ; Retrieve all the defined "flags" definitions for an owner
+4 ;
+5 ;Input
+6 ; FAKE - extra 'blank' parameter required by BMXNET async 'feature'
+7 ;Output
+8 ; DATA - name of global (passed by reference) in which the data
+9 ; is stored
+10 ;Assumes
+11 ; DUZ - User who signed onto iCare
+12 ;
+13 NEW UID,II,X,MIEN,SOURCE,PARMS,PIEN,NAME,PTYP,VALUE,PMIEN
+14 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+15 SET DATA=$NAME(^TMP("BQIPLFLG",UID))
+16 KILL @DATA
+17 ;
+18 SET II=0
+19 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPLFLG D UNWIND^%ZTER"
+20 ;
+21 SET @DATA@(II)="T00030SOURCE_NAME^T03200PARMS"_$CHAR(30)
+22 ;
+23 SET MIEN=0
+24 FOR
SET MIEN=$ORDER(^BQICARE(DUZ,10,MIEN))
IF 'MIEN
QUIT
Begin DoDot:1
+25 NEW DA,IENS
+26 SET DA(1)=DUZ
SET DA=MIEN
SET IENS=$$IENS^DILF(.DA)
+27 SET SOURCE=$$GET1^DIQ(90505.09,IENS,.01,"E")
+28 SET II=II+1
SET @DATA@(II)=SOURCE
+29 SET PIEN=0
SET PARMS=""
+30 FOR
SET PIEN=$ORDER(^BQICARE(DUZ,10,MIEN,1,PIEN))
IF 'PIEN
QUIT
Begin DoDot:2
+31 NEW DA,IENS
+32 SET DA(2)=DUZ
SET DA(1)=MIEN
SET DA=PIEN
SET IENS=$$IENS^DILF(.DA)
+33 SET NAME=$$GET1^DIQ(90505.1,IENS,.01,"E")
+34 SET PTYP=$$PTYP^BQIDCDF(SOURCE,NAME)
+35 IF PTYP="T"
SET VALUE=$$GET1^DIQ(90505.1,IENS,.03,"E")
+36 IF PTYP'="T"
SET VALUE=$$GET1^DIQ(90505.1,IENS,.02,"E")
+37 ; if the parameter type is a date, convert to non FileMan date format
+38 IF PTYP="D"
SET VALUE=$$FMTMDY^BQIUL1(VALUE)
+39 SET PARMS=PARMS_NAME_"="
+40 ;
+41 ; Check for values
+42 SET PMIEN=0
+43 FOR
SET PMIEN=$ORDER(^BQICARE(DUZ,10,MIEN,1,PIEN,1,PMIEN))
IF 'PMIEN
QUIT
Begin DoDot:3
+44 NEW DA,IENS
+45 SET DA(3)=DUZ
SET DA(2)=MIEN
SET DA(1)=PIEN
SET DA=PMIEN
SET IENS=$$IENS^DILF(.DA)
+46 IF PTYP="T"
SET VALUE=$$GET1^DIQ(90505.11,IENS,.02,"E")
+47 IF PTYP'="T"
SET VALUE=$$GET1^DIQ(90505.11,IENS,.01,"E")
+48 ; if the parameter type is a date, convert to non FileMan date format
+49 IF PTYP="D"
SET VALUE=$$FMTMDY^BQIUL1(VALUE)
+50 SET PARMS=PARMS_VALUE_$CHAR(29)
End DoDot:3
+51 ; Remove trailing $C(29)
+52 SET PARMS=$$TKO^BQIUL1(PARMS,$CHAR(29))
+53 SET PARMS=PARMS_VALUE_$CHAR(28)
End DoDot:2
+54 ; Remove trailing $C(28)
+55 SET PARMS=$$TKO^BQIUL1(PARMS,$CHAR(28))
+56 SET $PIECE(@DATA@(II),"^",2)=PARMS_$CHAR(30)
End DoDot:1
+57 ;
DONE SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
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,SRCNM,PARMS) ; EP - BQI SET FLAG PREFS
+1 ;
+2 ;Input
+3 ; SRCNM - Source Name of the flag
+4 ; PARMS - Parameters for the source
+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
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("BQIPLFLG",UID))
+11 KILL @DATA
+12 ;
+13 SET II=0
SET PARMS=$GET(PARMS,"")
+14 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPLFLG D UNWIND^%ZTER"
+15 ;
+16 SET PPIEN=$$PP^BQIDCDF(SRCNM)
IF PPIEN=-1
SET BMXSEC="Source not found."
QUIT
+17 SET @DATA@(II)="I00010RESULT"_$CHAR(30)
+18 ;
+19 NEW DA,DIC,DLAYGO
+20 SET DA(1)=DUZ
SET X=SRCNM
+21 SET DLAYGO=90505.09
SET DIC(0)="LNXZ"
+22 SET DIC="^BQICARE("_DA(1)_",10,"
+23 IF '$DATA(^BQICARE(DA(1),10,0))
SET ^BQICARE(DA(1),10,0)="^90505.09P^^"
+24 ;K DO,DD D FILE^DICN
+25 DO ^DIC
+26 SET ALDA=+Y
+27 IF ALDA=-1
SET II=II+1
SET @DATA@(II)="-1"_$CHAR(30)
GOTO DONE
+28 ;
+29 ; Clean out all the previous parameters
+30 NEW DA,DIK,PN,PDA
+31 SET DA(2)=DUZ
SET DA(1)=ALDA
SET DIK="^BQICARE("_DA(2)_",10,"_DA(1)_",1,"
SET PN=0
+32 FOR
SET PN=$ORDER(^BQICARE(DA(2),10,DA(1),1,PN))
IF 'PN
QUIT
SET DA=PN
DO ^DIK
+33 ;
+34 SET QFL=0
+35 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+36 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+37 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+38 SET PTYP=$$PTYP^BQIDCDF(SRCNM,NAME)
+39 NEW DA,IENS,DIC
+40 SET DA(2)=DUZ
SET DA(1)=ALDA
SET X=NAME
+41 SET DLAYGO=90505.1
SET DIC(0)="L"
SET DIC("P")=DLAYGO
+42 SET DIC="^BQICARE("_DA(2)_",10,"_DA(1)_",1,"
+43 IF '$DATA(^BQICARE(DA(2),10,DA(1),1,0))
SET ^BQICARE(DA(2),10,DA(1),1,0)="^90505.1^^"
+44 KILL DO,DD
DO FILE^DICN
+45 SET (DA,PDA)=+Y
+46 IF DA=-1
SET II=II+1
SET @DATA@(II)="-1"_$CHAR(30)
SET QFL=1
QUIT
+47 ;
+48 NEW DA,IENS
+49 SET DA(2)=DUZ
SET DA(1)=ALDA
SET DA=PDA
+50 SET IENS=$$IENS^DILF(.DA)
+51 IF VALUE'[$CHAR(29)
Begin DoDot:2
+52 ; if the parameter type is a date, convert to FileMan date format
+53 IF PTYP="D"
SET VALUE=$$DATE^BQIUL1(VALUE)
+54 IF PTYP="T"
SET BQIUPD(90505.1,IENS,.03)=VALUE
+55 IF PTYP'="T"
SET BQIUPD(90505.1,IENS,.02)=VALUE
+56 DO FILE^DIE("","BQIUPD","ERROR")
+57 KILL BQIUPD
End DoDot:2
QUIT
+58 ;
+59 IF VALUE[$CHAR(29)
Begin DoDot:2
+60 IF '$DATA(^BQICARE(DA(2),10,DA(1),1,DA,1,0))
SET ^BQICARE(DA(2),10,DA(1),1,DA,1,0)="^90505.11^^"
+61 FOR BQII=1:1:$LENGTH(VALUE,$CHAR(29))
Begin DoDot:3
+62 SET MVAL=$PIECE(VALUE,$CHAR(29),BQII)
+63 NEW DA,IENS
+64 SET DA(3)=DUZ
SET DA(2)=ALDA
SET DA(1)=PDA
SET X=MVAL
+65 SET DLAYGO=90505.11
SET DIC(0)="L"
SET DIC("P")=DLAYGO
+66 SET DIC="^BQICARE("_DA(3)_",10,"_DA(2)_",1,"_DA(1)_",1,"
+67 KILL DO,DD
DO FILE^DICN
+68 SET DA=+Y
+69 IF DA=-1
SET II=II+1
SET @DATA@(II)="-1"_$CHAR(30)
SET QFL=1
QUIT
+70 ; if the parameter type is a date, convert to FileMan date format
+71 IF PTYP="D"
SET MVAL=$$DATE^BQIUL1(MVAL)
+72 SET IENS=$$IENS^DILF(.DA)
+73 IF PTYP="T"
SET BQIUPD(90505.11,IENS,.02)=MVAL
+74 DO FILE^DIE("","BQIUPD","ERROR")
+75 KILL BQIUPD
End DoDot:3
End DoDot:2
IF QFL
QUIT
End DoDot:1
IF QFL
GOTO DONE
+76 ;
+77 SET II=II+1
SET @DATA@(II)="1"_$CHAR(30)
+78 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+79 QUIT
+80 ;
DELA(DATA) ; Delete all flag definitions
+1 NEW UID,II,DA,DIK
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BQIPLFLG",UID))
+4 KILL @DATA
+5 ;
+6 SET II=0
+7 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPLFLG D UNWIND^%ZTER"
+8 SET @DATA@(II)="I00010RESULT"_$CHAR(30)
+9 SET DA(1)=DUZ
SET DA=0
SET DIK="^BQICARE("_DA(1)_",10,"
+10 FOR
SET DA=$ORDER(^BQICARE(DUZ,10,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 flag definitions
+1 NEW DA,DIK
+2 SET DA(1)=DUZ
SET DA=0
SET DIK="^BQICARE("_DA(1)_",10,"
+3 FOR
SET DA=$ORDER(^BQICARE(DUZ,10,DA))
IF 'DA
QUIT
DO ^DIK
+4 QUIT
+5 ;
GPARMS(USR,ADSC,PARMS,MPARMS) ;EP - Get parameters for a user's flag preference
+1 ;
+2 ;Input
+3 ; USR = User/Owner internal entry number
+4 ; ADSC = Flag description
+5 ;
+6 NEW DA,IENS,DIC,AIEN,SOURCE,PIEN,PTYP,VALUE,PMIEN
+7 SET DA(1)=USR
SET X=ADSC
SET DIC(0)="XZ"
SET DIC="^BQICARE("_DA(1)_",10,"
+8 DO ^DIC
+9 IF +Y<1
QUIT
+10 SET (DA,AIEN)=+Y
SET IENS=$$IENS^DILF(.DA)
+11 SET SOURCE=$$GET1^DIQ(90505.09,IENS,.01,"E")
+12 SET PIEN=0
SET PARMS=""
+13 FOR
SET PIEN=$ORDER(^BQICARE(USR,10,AIEN,1,PIEN))
IF 'PIEN
QUIT
Begin DoDot:1
+14 NEW DA,IENS
+15 SET DA(2)=USR
SET DA(1)=AIEN
SET DA=PIEN
SET IENS=$$IENS^DILF(.DA)
+16 SET NAME=$$GET1^DIQ(90505.1,IENS,.01,"E")
+17 SET PTYP=$$PTYP^BQIDCDF(SOURCE,NAME)
+18 ; if the parameter type is a table, use the pointer (IEN) value
+19 IF PTYP="T"
SET VALUE=$$GET1^DIQ(90505.1,IENS,.03,"E")
+20 ; if the parameter type is not a table, use the free text value
+21 IF PTYP'="T"
SET VALUE=$$GET1^DIQ(90505.1,IENS,.02,"E")
+22 ; if the parameter type is a date, convert to FileMan date format
+23 IF PTYP="D"
SET VALUE=$$DATE^BQIUL1(VALUE)
+24 SET PARMS(NAME)=VALUE
+25 ;
+26 ; Check for values
+27 SET PMIEN=0
+28 FOR
SET PMIEN=$ORDER(^BQICARE(USR,10,AIEN,1,PIEN,1,PMIEN))
IF 'PMIEN
QUIT
Begin DoDot:2
+29 NEW DA,IENS
+30 SET DA(3)=USR
SET DA(2)=AIEN
SET DA(1)=PIEN
SET DA=PMIEN
SET IENS=$$IENS^DILF(.DA)
+31 ;
+32 ; if the parameter type is a table, use the pointer (IEN) value
+33 IF PTYP="T"
SET VALUE=$$GET1^DIQ(90505.11,IENS,.02,"E")
+34 ; if the parameter type is not a table, use the free text value
+35 IF PTYP'="T"
SET VALUE=$$GET1^DIQ(90505.11,IENS,.01,"E")
+36 SET MPARMS(NAME,VALUE)=""
End DoDot:2
End DoDot:1
+37 QUIT
