BQIPLMY ;PRXM/HC/ALA-Get "My Patients" Definition ; 29 Nov 2005 4:59 PM
;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
;
Q
;
RET(DATA,OWNR) ; EP - BQI GET USER MY PATIENTS DEF
;
;Description
; Retrieve all the defined "my patients" definitions for an owner
;
;Input
; OWNR - Person to retrieve the "my patients" definition for
; If not defined, it is assumed to be the user
;
;Output
; DATA - name of global (passed by reference) in which the data
; is stored
;Assumes
; DUZ - User who signed onto iCare
;
NEW UID,II,MIEN,PARMS,PIEN,PMIEN,VALUE,X
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPLMY",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPLMY D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S OWNR=$G(OWNR,"") S:OWNR="" OWNR=DUZ
S @DATA@(II)="T00030SOURCE_NAME^T00250GENERATED_DESCRIPTION^T03200PARMS"_$C(30)
;
S MIEN=0
F S MIEN=$O(^BQICARE(OWNR,7,MIEN)) Q:'MIEN D
. NEW DA,IENS
. S DA(1)=OWNR,DA=MIEN,IENS=$$IENS^DILF(.DA)
. S II=II+1
. S @DATA@(II)=$$GET1^DIQ(90505.07,IENS,.01,"E")_"^"_$$GET1^DIQ(90505.07,IENS,2,"E")_"^"
. S PIEN=0,PARMS=""
. F S PIEN=$O(^BQICARE(OWNR,7,MIEN,10,PIEN)) Q:'PIEN D
.. NEW DA,IENS
.. S DA(2)=OWNR,DA(1)=MIEN,DA=PIEN,IENS=$$IENS^DILF(.DA)
.. S PARMS=PARMS_$$GET1^DIQ(90505.08,IENS,.01,"E")_"="
.. ;
.. ; Check for multiple values
.. S PMIEN=0
.. F S PMIEN=$O(^BQICARE(OWNR,7,MIEN,10,PIEN,1,PMIEN)) Q:'PMIEN D
... NEW DA,IENS
... S DA(3)=OWNR,DA(2)=MIEN,DA(1)=PIEN,DA=PMIEN,IENS=$$IENS^DILF(.DA)
... S VALUE=$S($$GET1^DIQ(90505.81,IENS,.02,"E")'="":$$GET1^DIQ(90505.81,IENS,.02,"E"),1:$$GET1^DIQ(90505.81,IENS,.01,"E"))
... S PARMS=PARMS_VALUE_$C(29)
.. ; remove trailing $C(29)
.. S PARMS=$$TKO^BQIUL1(PARMS,$C(29))
.. S VALUE=$S($$GET1^DIQ(90505.08,IENS,.02,"E")'="":$$GET1^DIQ(90505.08,IENS,.02,"E"),1:$$GET1^DIQ(90505.08,IENS,.03,"E"))
.. S PARMS=PARMS_VALUE_$C(28)
. ; remove trailing $C(28)
. S PARMS=$$TKO^BQIUL1(PARMS,$C(28))
. S @DATA@(II)=@DATA@(II)_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
;
DEL ; Delete the previous 'My Patients' definitions
NEW DA,DIK
S DA(1)=OWNR,DA=0,DIK="^BQICARE("_DA(1)_",7,"
F S DA=$O(^BQICARE(OWNR,7,DA)) Q:'DA D ^DIK
Q
;
UPD(DATA,SRCNM,PARMS) ; EP - BQI SET USER MY PATIENTS DEF
;Input
; SRCNM - Source Name of the My Patient definition
; PARMS - Parameters for the source
;Assumes
; DUZ - User who signed onto iCare
;
NEW UID,II,MIEN,PIEN,PMIEN,VALUE,X,PPIEN
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPLMY",UID))
K @DATA
;
I '$$OWNR^BQIPLUSR(DUZ) S BMXSEC="There is a problem with your entry." Q
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPLMY D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S PARMS=$G(PARMS,"")
S PPIEN=$$PP^BQIDCDF(SRCNM) I PPIEN=-1 S BMXSEC="Source not found." Q
S @DATA@(II)="I00010RESULT"_$C(30)
;
NEW DA,DIC,DLAYGO,BDATA,BQ,BQI,ALDA,QFL
S DA(1)=DUZ,X=SRCNM
S DLAYGO=90505.07,DIC(0)="LNXZ"
S DIC="^BQICARE("_DA(1)_",7,"
I '$D(^BQICARE(DA(1),7,0)) S ^BQICARE(DA(1),7,0)="^90505.07P^^"
D ^DIC
S ALDA=+Y
I ALDA=-1 S II=II+1,@DATA@(II)="-1"_$C(30) G DONE
;
; delete parameters before storing new values
NEW DA,DIK,PN
S DA(2)=DUZ,DA(1)=ALDA,DIK="^BQICARE("_DA(2)_",7,"_DA(1)_",10,",PN=0
F S PN=$O(^BQICARE(DA(2),7,DA(1),10,PN)) Q:'PN S DA=PN D ^DIK
;
NEW QFL,BQ,BDATA,PTYP,BQI,VALUE,MVAL,NAME,PDA
S QFL=0
F BQ=1:1:$L(PARMS,$C(28)) D G DONE:QFL
. S BDATA=$P(PARMS,$C(28),BQ) Q:BDATA=""
. S NAME=$P(BDATA,"=",1),VALUE=$P(BDATA,"=",2,99)
. S PTYP=$$PTYP^BQIDCDF(SRCNM,NAME)
. NEW DA,IENS,DIC
. S DA(2)=DUZ,DA(1)=ALDA,X=NAME
. S DLAYGO=90505.08,DIC(0)="L",DIC("P")=DLAYGO
. S DIC="^BQICARE("_DA(2)_",7,"_DA(1)_",10,"
. I '$D(^BQICARE(DA(2),7,DA(1),10,0)) S ^BQICARE(DA(2),7,DA(1),10,0)="^90505.08^^"
. 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
.. I PTYP="D" S VALUE=$$DATE^BQIUL1(VALUE)
.. I PTYP="T" S BQIUPD(90505.08,IENS,.03)=VALUE
.. I PTYP'="T" S BQIUPD(90505.08,IENS,.02)=VALUE
.. D FILE^DIE("","BQIUPD","ERROR")
.. K BQIUPD
. ;
. I VALUE[$C(29) D Q:QFL
.. I '$D(^BQICARE(DA(2),7,DA(1),1,DA,1,0)) S ^BQICARE(DA(2),7,DA(1),1,DA,1,0)="^90505.81^^"
.. F BQI=1:1:$L(VALUE,$C(29)) D
... S MVAL=$P(VALUE,$C(29),BQI)
... NEW DA,IENS
... S DA(3)=DUZ,DA(2)=ALDA,DA(1)=PDA,X=MVAL
... S DLAYGO=90505.81,DIC(0)="L",DIC("P")=DLAYGO
... S DIC="^BQICARE("_DA(3)_",7,"_DA(2)_",10,"_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
... I PTYP="D" S MVAL=$$DATE^BQIUL1(MVAL)
... S IENS=$$IENS^DILF(.DA)
... I PTYP="T" S BQIUPD(90505.81,IENS,.02)=MVAL
... D FILE^DIE("","BQIUPD","ERROR")
... K BQIUPD
;
DSC ; Update generated description
S ALDA=0
F S ALDA=$O(^BQICARE(DUZ,7,ALDA)) Q:'ALDA D
. NEW DA,IENS
. S DA(1)=DUZ,DA=ALDA,IENS=$$IENS^DILF(.DA)
. S BQIUPD(90505.07,IENS,2)=$$MEN^BQIPLDSC(DUZ,ALDA)
. 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
BQIPLMY ;PRXM/HC/ALA-Get "My Patients" Definition ; 29 Nov 2005 4:59 PM
+1 ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
+3 QUIT
+4 ;
RET(DATA,OWNR) ; EP - BQI GET USER MY PATIENTS DEF
+1 ;
+2 ;Description
+3 ; Retrieve all the defined "my patients" definitions for an owner
+4 ;
+5 ;Input
+6 ; OWNR - Person to retrieve the "my patients" definition for
+7 ; If not defined, it is assumed to be the user
+8 ;
+9 ;Output
+10 ; DATA - name of global (passed by reference) in which the data
+11 ; is stored
+12 ;Assumes
+13 ; DUZ - User who signed onto iCare
+14 ;
+15 NEW UID,II,MIEN,PARMS,PIEN,PMIEN,VALUE,X
+16 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+17 SET DATA=$NAME(^TMP("BQIPLMY",UID))
+18 KILL @DATA
+19 ;
+20 SET II=0
+21 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPLMY D UNWIND^%ZTER"
+22 ;
+23 SET OWNR=$GET(OWNR,"")
IF OWNR=""
SET OWNR=DUZ
+24 SET @DATA@(II)="T00030SOURCE_NAME^T00250GENERATED_DESCRIPTION^T03200PARMS"_$CHAR(30)
+25 ;
+26 SET MIEN=0
+27 FOR
SET MIEN=$ORDER(^BQICARE(OWNR,7,MIEN))
IF 'MIEN
QUIT
Begin DoDot:1
+28 NEW DA,IENS
+29 SET DA(1)=OWNR
SET DA=MIEN
SET IENS=$$IENS^DILF(.DA)
+30 SET II=II+1
+31 SET @DATA@(II)=$$GET1^DIQ(90505.07,IENS,.01,"E")_"^"_$$GET1^DIQ(90505.07,IENS,2,"E")_"^"
+32 SET PIEN=0
SET PARMS=""
+33 FOR
SET PIEN=$ORDER(^BQICARE(OWNR,7,MIEN,10,PIEN))
IF 'PIEN
QUIT
Begin DoDot:2
+34 NEW DA,IENS
+35 SET DA(2)=OWNR
SET DA(1)=MIEN
SET DA=PIEN
SET IENS=$$IENS^DILF(.DA)
+36 SET PARMS=PARMS_$$GET1^DIQ(90505.08,IENS,.01,"E")_"="
+37 ;
+38 ; Check for multiple values
+39 SET PMIEN=0
+40 FOR
SET PMIEN=$ORDER(^BQICARE(OWNR,7,MIEN,10,PIEN,1,PMIEN))
IF 'PMIEN
QUIT
Begin DoDot:3
+41 NEW DA,IENS
+42 SET DA(3)=OWNR
SET DA(2)=MIEN
SET DA(1)=PIEN
SET DA=PMIEN
SET IENS=$$IENS^DILF(.DA)
+43 SET VALUE=$SELECT($$GET1^DIQ(90505.81,IENS,.02,"E")'="":$$GET1^DIQ(90505.81,IENS,.02,"E"),1:$$GET1^DIQ(90505.81,IENS,.01,"E"))
+44 SET PARMS=PARMS_VALUE_$CHAR(29)
End DoDot:3
+45 ; remove trailing $C(29)
+46 SET PARMS=$$TKO^BQIUL1(PARMS,$CHAR(29))
+47 SET VALUE=$SELECT($$GET1^DIQ(90505.08,IENS,.02,"E")'="":$$GET1^DIQ(90505.08,IENS,.02,"E"),1:$$GET1^DIQ(90505.08,IENS,.03,"E"))
+48 SET PARMS=PARMS_VALUE_$CHAR(28)
End DoDot:2
+49 ; remove trailing $C(28)
+50 SET PARMS=$$TKO^BQIUL1(PARMS,$CHAR(28))
+51 SET @DATA@(II)=@DATA@(II)_PARMS_$CHAR(30)
End DoDot:1
+52 ;
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 ;
DEL ; Delete the previous 'My Patients' definitions
+1 NEW DA,DIK
+2 SET DA(1)=OWNR
SET DA=0
SET DIK="^BQICARE("_DA(1)_",7,"
+3 FOR
SET DA=$ORDER(^BQICARE(OWNR,7,DA))
IF 'DA
QUIT
DO ^DIK
+4 QUIT
+5 ;
UPD(DATA,SRCNM,PARMS) ; EP - BQI SET USER MY PATIENTS DEF
+1 ;Input
+2 ; SRCNM - Source Name of the My Patient definition
+3 ; PARMS - Parameters for the source
+4 ;Assumes
+5 ; DUZ - User who signed onto iCare
+6 ;
+7 NEW UID,II,MIEN,PIEN,PMIEN,VALUE,X,PPIEN
+8 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+9 SET DATA=$NAME(^TMP("BQIPLMY",UID))
+10 KILL @DATA
+11 ;
+12 IF '$$OWNR^BQIPLUSR(DUZ)
SET BMXSEC="There is a problem with your entry."
QUIT
+13 ;
+14 SET II=0
+15 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPLMY D UNWIND^%ZTER"
+16 ;
+17 SET PARMS=$GET(PARMS,"")
+18 SET PPIEN=$$PP^BQIDCDF(SRCNM)
IF PPIEN=-1
SET BMXSEC="Source not found."
QUIT
+19 SET @DATA@(II)="I00010RESULT"_$CHAR(30)
+20 ;
+21 NEW DA,DIC,DLAYGO,BDATA,BQ,BQI,ALDA,QFL
+22 SET DA(1)=DUZ
SET X=SRCNM
+23 SET DLAYGO=90505.07
SET DIC(0)="LNXZ"
+24 SET DIC="^BQICARE("_DA(1)_",7,"
+25 IF '$DATA(^BQICARE(DA(1),7,0))
SET ^BQICARE(DA(1),7,0)="^90505.07P^^"
+26 DO ^DIC
+27 SET ALDA=+Y
+28 IF ALDA=-1
SET II=II+1
SET @DATA@(II)="-1"_$CHAR(30)
GOTO DONE
+29 ;
+30 ; delete parameters before storing new values
+31 NEW DA,DIK,PN
+32 SET DA(2)=DUZ
SET DA(1)=ALDA
SET DIK="^BQICARE("_DA(2)_",7,"_DA(1)_",10,"
SET PN=0
+33 FOR
SET PN=$ORDER(^BQICARE(DA(2),7,DA(1),10,PN))
IF 'PN
QUIT
SET DA=PN
DO ^DIK
+34 ;
+35 NEW QFL,BQ,BDATA,PTYP,BQI,VALUE,MVAL,NAME,PDA
+36 SET QFL=0
+37 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+38 SET BDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF BDATA=""
QUIT
+39 SET NAME=$PIECE(BDATA,"=",1)
SET VALUE=$PIECE(BDATA,"=",2,99)
+40 SET PTYP=$$PTYP^BQIDCDF(SRCNM,NAME)
+41 NEW DA,IENS,DIC
+42 SET DA(2)=DUZ
SET DA(1)=ALDA
SET X=NAME
+43 SET DLAYGO=90505.08
SET DIC(0)="L"
SET DIC("P")=DLAYGO
+44 SET DIC="^BQICARE("_DA(2)_",7,"_DA(1)_",10,"
+45 IF '$DATA(^BQICARE(DA(2),7,DA(1),10,0))
SET ^BQICARE(DA(2),7,DA(1),10,0)="^90505.08^^"
+46 KILL DO,DD
DO FILE^DICN
+47 SET (DA,PDA)=+Y
+48 IF DA=-1
SET II=II+1
SET @DATA@(II)="-1"_$CHAR(30)
SET QFL=1
QUIT
+49 ;
+50 NEW DA,IENS
+51 SET DA(2)=DUZ
SET DA(1)=ALDA
SET DA=PDA
+52 SET IENS=$$IENS^DILF(.DA)
+53 IF VALUE'[$CHAR(29)
Begin DoDot:2
+54 IF PTYP="D"
SET VALUE=$$DATE^BQIUL1(VALUE)
+55 IF PTYP="T"
SET BQIUPD(90505.08,IENS,.03)=VALUE
+56 IF PTYP'="T"
SET BQIUPD(90505.08,IENS,.02)=VALUE
+57 DO FILE^DIE("","BQIUPD","ERROR")
+58 KILL BQIUPD
End DoDot:2
QUIT
+59 ;
+60 IF VALUE[$CHAR(29)
Begin DoDot:2
+61 IF '$DATA(^BQICARE(DA(2),7,DA(1),1,DA,1,0))
SET ^BQICARE(DA(2),7,DA(1),1,DA,1,0)="^90505.81^^"
+62 FOR BQI=1:1:$LENGTH(VALUE,$CHAR(29))
Begin DoDot:3
+63 SET MVAL=$PIECE(VALUE,$CHAR(29),BQI)
+64 NEW DA,IENS
+65 SET DA(3)=DUZ
SET DA(2)=ALDA
SET DA(1)=PDA
SET X=MVAL
+66 SET DLAYGO=90505.81
SET DIC(0)="L"
SET DIC("P")=DLAYGO
+67 SET DIC="^BQICARE("_DA(3)_",7,"_DA(2)_",10,"_DA(1)_",1,"
+68 KILL DO,DD
DO FILE^DICN
+69 SET DA=+Y
+70 IF DA=-1
SET II=II+1
SET @DATA@(II)="-1"_$CHAR(30)
SET QFL=1
QUIT
+71 IF PTYP="D"
SET MVAL=$$DATE^BQIUL1(MVAL)
+72 SET IENS=$$IENS^DILF(.DA)
+73 IF PTYP="T"
SET BQIUPD(90505.81,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 ;
DSC ; Update generated description
+1 SET ALDA=0
+2 FOR
SET ALDA=$ORDER(^BQICARE(DUZ,7,ALDA))
IF 'ALDA
QUIT
Begin DoDot:1
+3 NEW DA,IENS
+4 SET DA(1)=DUZ
SET DA=ALDA
SET IENS=$$IENS^DILF(.DA)
+5 SET BQIUPD(90505.07,IENS,2)=$$MEN^BQIPLDSC(DUZ,ALDA)
+6 DO FILE^DIE("","BQIUPD","ERROR")
+7 KILL BQIUPD
End DoDot:1
+8 ;
+9 SET II=II+1
SET @DATA@(II)="1"_$CHAR(30)
+10 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+11 ;
+12 QUIT
