BQIRPL ;PRXM/HC/DLS - Patient Problem List ; 15 Jun 2008 8:09 PM
;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
;
Q
;
EN(DATA,DFN,DRANGE,BQPIEN,DEL) ; EP - BQI PATIENT PROBLEM LIST
;Description
; Generates a Patient Problem List for a given DFN and Relative Date.
;
;Input
; DFN - Patient IEN
; DRANGE - Date to pull Patient Problem entered from (to the present).
; BQPIEN - Specific problem IEN
; DEL - "D" for deletes only, otherwise blank
;
;Output
; DATA - Name of global in which data is stored(^TMP("BQIRPL",UID))
;
N UID,X,BQII,DA,IENS,BQIUPDT,LOC,BQAPID,BQID,BQIEN,SDATA
N BQPRB,BQPRID,BQDX,BQST,BQONSET,BQNARR,BQNOTEF,BQCLS,NLOC
N BQNDE0,BQCNT,BQDL,BQNOTE,BQNDX,BQPRBDT,BQPRV,BQSTN,BQIUSUP
N BQICLAS,BQNIEN,HBQNARR,BQITCDT,BQITEPR
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIRPL",UID)),SDATA=$NA(^TMP("BQISPL",UID))
K @DATA,@SDATA
;
S BQII=0
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S BQPIEN=$G(BQPIEN,""),DFN=$G(DFN,""),DRANGE=$G(DRANGE,""),DEL=$G(DEL,"")
;
D HDR
;
I DRANGE'="" S DRANGE=$$DATE^BQIUL1($G(DRANGE))
;
I BQPIEN="",DFN'="",'$D(^AUPNPROB("AC",DFN)) G DONE
;
I BQPIEN'="" D GETDATA(BQPIEN) G DONE
;
F S BQPIEN=$O(^AUPNPROB("AC",DFN,BQPIEN)) Q:BQPIEN="" D GETDATA(BQPIEN)
;
DONE ;
S BQST=""
F S BQST=$O(@SDATA@(BQST)) Q:BQST="" D
. S BQID=""
. F S BQID=$O(@SDATA@(BQST,BQID)) Q:BQID="" D
.. S BQIEN=""
.. F S BQIEN=$O(@SDATA@(BQST,BQID,BQIEN)) Q:BQIEN="" D
... S BQII=BQII+1
... S @DATA@(BQII)=BQIEN_U_@SDATA@(BQST,BQID,BQIEN)_$C(30)
S BQII=BQII+1,@DATA@(BQII)=$C(31)
K @SDATA
Q
;
GETDATA(BQPIEN) ;EP
;
S DA=BQPIEN
S IENS=$$IENS^DILF(.DA)
S BQPRBDT=$$GET1^DIQ(9000011,IENS,".08","I")
I DRANGE'="",BQPRBDT<DRANGE Q
S BQPRBDT=$$FMTE^BQIUL1(BQPRBDT)
;
S BQCLS=$$GET1^DIQ(9000011,IENS,.04,"I")_$C(28)_$$GET1^DIQ(9000011,IENS,.04,"E")
S BQNDE0=$G(^AUPNPROB(BQPIEN,0))
S LOC=$P(BQNDE0,U,6)
S BQPRID=$S(LOC="":"??",$P($G(^AUTTLOC(LOC,0)),U,7)]"":$J($P(^AUTTLOC(LOC,0),U,7),4),1:"??")_$P(BQNDE0,U,7)
S BQAPID=$S(LOC="":"??",$P($G(^AUTTLOC(LOC,0)),U,7)]"":$J($P(^AUTTLOC(LOC,0),U,7),4),1:"??")_$E("0000",1,4-$L($P(BQNDE0,U,7)))_$P(BQNDE0,U,7)
I $$VERSION^XPDUTL("BCSV") S BQDX=$$ICD9^BQIUL3($P(BQNDE0,U),,2) ; Code set versioning
I '$$VERSION^XPDUTL("BCSV") S BQDX=$P(^ICD9($P(BQNDE0,U),0),U)
I BQDX'="",$$VERSION^XPDUTL("BCSV") S BQDX=$P(BQNDE0,U)_$C(28)_BQDX_" - "_$$ICD9^BQIUL3($P(BQNDE0,U),,4)
I BQDX'="",'$$VERSION^XPDUTL("BCSV") S BQDX=$P(BQNDE0,U)_$C(28)_BQDX_" - "_$P(^ICD9($P(BQNDE0,U),0),U,3)
;
S BQST=$$GET1^DIQ(9000011,BQPIEN_",",.12,"E")
S BQSTN=$$GET1^DIQ(9000011,BQPIEN_",",.12,"I")
S BQONSET=$$FMTE^BQIUL1($P($G(BQNDE0),U,13))
S BQIUPDT=$$FMTE^BQIUL1($P($G(BQNDE0),U,3))
S BQIUSUP=$$GET1^DIQ(9000011,BQPIEN_",",.14,"E")
S (BQITCDT,BQITEPR)=""
I DEL'="D" D
. S BQITCDT=$$LASTPLU^APCLAPI6(DFN,,DT,"A")
. ;
. ;Pull time from entry if not defined (current API doesnt return time)
. I $P($P(BQITCDT,U),".",2)="" D
.. N IEN,DTM
.. S IEN=$P(BQITCDT,U,6) Q:IEN=""
.. S DTM=$$GET1^DIQ(9000010.54,IEN_",",1201,"I")
.. S:DTM["." $P(BQITCDT,U)=DTM
. ;
. S BQITEPR=$P(BQITCDT,U,3)_$C(28)_$$GET1^DIQ(200,$P(BQITCDT,U,3)_",",.01,"E"),BQITCDT=$$FMTE^BQIUL1($P(BQITCDT,U))
;S:BQIUSUP="" BQIUSUP=$$GET1^DIQ(9000011,BQPIEN_",",1.03,"E")
S BQICLAS=""
I $G(^DD(9000011,.15,0))'="" D
. S BQICLAS=$$GET1^DIQ(9000011,BQPIEN_",",.15,"I")_$C(28)_$$GET1^DIQ(9000011,BQPIEN_",",.15,"E")
S BQNARR=$P($G(^AUTNPOV(+$P(BQNDE0,U,5),0)),U),BQNIEN=+$P(BQNDE0,U,5)
S HBQNARR=BQNIEN
I $$PATCH^XPDUTL("BJPC*2.0*10") S BQNARR=$$PNPROB^AUPNVUTL(BQNIEN)
S BQNOTE=$$NOT(BQPIEN)
S:LOC'="" LOC=LOC_$C(28)_$$GET1^DIQ(9999999.06,LOC_",",.01,"E")
S BQST=$S(BQST="":"UNKNOWN",1:BQST)
S @SDATA@(BQST,BQAPID,BQPIEN)=BQPRID_U_BQPRBDT_U_LOC_U_BQIUSUP_U_BQIUPDT_U_BQDX_U_BQCLS_U_$G(BQSTN)_$C(28)_BQST_U_BQONSET_U_HBQNARR_U_BQNARR_U_BQNOTE_U_BQICLAS_U_DFN_U_BQITCDT_U_BQITEPR
Q
;
HDR ;
S @DATA@(BQII)="I00010PBLIEN^T00004PBLID^D00015APCDDTE^T00030APCDFAC^T00050BQIUSLM^D00015APCDDLM^T00007APCDDX^T00020APCDCLS^T00008APCDSTAT^D00015APCDDOO^T00080APCDN^"
S @DATA@(BQII)=@DATA@(BQII)_"T00080PRVNAR^T01024PBLNOTES^T00030APCDCLAS^I00010DFN^D00030APCDTCDT^T00035APCDTEPR"_$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(BQII),$D(DATA) S BQII=BQII+1,@DATA@(BQII)=$C(31)
Q
;
UPD(DATA,DFN,TYPE,PBLIEN,PARMS) ;EP - BQI UPDATE PROBLEM LIST
;Input
; DFN - Patient internal entry number
; TYPE - 'A' to add or 'D' to delete
; PBLIEN - Problem IEN
; PARMS - Data values
;
NEW UID,II,APCDCLS,APCDDLM,APCDDOO,APCDDTE,APCDDX,APCDFAC,APCDP,APCDSTAT
NEW PBLPR,PBLNB,PBLID,PRVNAR,APCDCLAS,APCDEBU,APCDN,BN,BQ,BQIDATA,CHIEN
NEW FIELD,FILE,FNME,VFIEN,RESULT,LIST,PDATA,NAME,VALUE,PFIEN,PTYP,MSG,ERROR
NEW APCDP,VER,NM,QFL,BQIUPD,APCDTCDT,APCDTEPR,APCDEC1,APCDEC2,APCDEC3
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIRPLU",UID))
K @DATA
;
S BQII=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(BQII)="I00010RESULT^T01024MSG^I00010PBLIEN"_$C(30)
S VFIEN=$O(^BQI(90506.3,"B","Problem List",""))
I VFIEN="" S BMXSEC="RPC Call Failed: Problem List Definition does not exist." Q
S FILE=$P(^BQI(90506.3,VFIEN,0),U,2)
;
S TYPE=$G(TYPE,""),PBLIEN=$G(PBLIEN,"")
I TYPE="D" D G DNE
. S RESULT=$$DELPROB^APCDALV2(PBLIEN),MSG=""
. S RESULT=$S(RESULT="":1,1:RESULT)
. I RESULT=-1 S MSG="Unable to delete Problem"
. S RESULT=RESULT_U_MSG
;
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
;
F BQ=1:1:$L(PARMS,$C(28)) D
. N EXEC
. S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99) I VALUE="" Q
. S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
. S PTYP=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
. I PTYP="D"!(PTYP="A") S VALUE=$$DATE^BQIUL1(VALUE)
. ;I PTYP="T" S VALUE=VALUE
. I PTYP="C" D
.. S CHIEN=$O(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,"")) I CHIEN="" Q
.. S VALUE=$P(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
. S FIELD=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
. S EXEC=$G(^BQI(90506.3,VFIEN,10,PFIEN,7))
. I EXEC'="" X EXEC Q
. I TYPE="A" D
.. S @NAME=VALUE,BQIDATA(NAME)=FIELD
. I TYPE="E" S BQIUPD(FILE,PBLIEN_",",FIELD)=VALUE,@NAME=VALUE
;
I TYPE="E" D
. I $D(BQIUPD) S BQIUPD(FILE,PBLIEN_",",.14)=DUZ,BQIUPD(FILE,PBLIEN_",",.03)=DT
. I $G(APCDCLAS)="",$P(^AUPNPROB(PBLIEN,0),U,15)'="" S BQIUPD(FILE,PBLIEN_",",.15)="@"
. D FILE^DIE("","BQIUPD","ERROR")
. K BQIUPD
. S RESULT=1_U
. I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR","1","TEXT","1"))
;
I TYPE="A" D
. S APCDP=DFN
. S FNME="APC"
. F S FNME=$O(^BQI(90506.3,VFIEN,10,"AC",FNME)) Q:FNME=""!($E(FNME,1,3)'="APC") D
.. S @FNME=$G(@FNME,"")
. ;
. S VER=$$VERSION^XPDUTL("BJPC")
. I VER<2.0 D
.. I $$PATCH^XPDUTL("BJPC*1.0*1") S RESULT=$$ADDPROB^APCDALV2("`"_APCDDX,APCDP,APCDDLM,APCDCLS,PRVNAR,APCDFAC,APCDDTE,APCDSTAT,APCDDOO) Q
.. I $$PATCH^XPDUTL("BJPC*1.0*2") S RESULT=$$ADDPROB^APCDALV2("`"_APCDDX,APCDP,APCDDLM,APCDCLS,"`"_APCDN,APCDFAC,APCDDTE,APCDSTAT,APCDDOO)
. I VER>1.0 D
.. I $G(APCDDOO)'="" S APCDDOO=$$FMTE^XLFDT(APCDDOO,1)
.. S RESULT=$$ADDPROB^APCDALV2("`"_APCDDX,APCDP,APCDDLM,APCDCLS,"`"_APCDN,APCDFAC,APCDDTE,APCDSTAT,APCDDOO,APCDCLAS,$G(APCDEBU),$G(APCDEC1),$G(APCDEC2),$G(APCDEC3))
. S MSG=$P($T(EMSG+RESULT),";;",2)
. I RESULT D
.. S IEN="",QFL=0
.. F S IEN=$O(^AUPNPROB("AC",DFN,IEN),-1) Q:IEN=""!QFL D
... I $P(^AUPNPROB(IEN,0),U)=APCDDX,$P($G(^AUPNPROB(IEN,1)),U,3)=DUZ S PBLIEN=IEN,QFL=1
.. I $G(PBLIEN)'="" D
... S BQIUPD(FILE,PBLIEN_",",.14)=DUZ
... I $G(APCDCLAS)="",$P(^AUPNPROB(PBLIEN,0),U,15)'="" S BQIUPD(FILE,PBLIEN_",",.15)="@"
.. D FILE^DIE("","BQIUPD","ERROR")
.. K BQIUPD
. I 'RESULT D
.. NEW IEN
.. S IEN="",QFL=0
.. F S IEN=$O(^AUPNPROB("AC",DFN,IEN),-1) Q:IEN=""!(QFL) D
... I $P(^AUPNPROB(IEN,0),U,1)'=APCDDX Q
... I $P($G(^AUPNPROB(IEN,1)),U,3)=DUZ S QFL=1,PBLIEN=IEN
... S NM="PBL"
... F S NM=$O(BQIDATA(NM)) Q:NM=""!($E(NM,1,3)'="PBL") D
.... S FIELD=BQIDATA(NM),BQIUPD(FILE,PBLIEN_",",FIELD)=$G(@NM)
... S BQIUPD(FILE,PBLIEN_",",.14)=DUZ
... D FILE^DIE("","BQIUPD","ERROR")
... K BQIUPD
. S RESULT=$S(RESULT>0:-1,1:1)_U_MSG
;
;Log V UPDATED/REVIEWED (Updated) entry
DNE ; EP
I +RESULT=1 D VUP("PROBLEM LIST UPDATED")
;
S BQII=BQII+1,@DATA@(BQII)=RESULT_U_$G(PBLIEN)_$C(30)
S BQII=BQII+1,@DATA@(BQII)=$C(31)
Q
;
VUP(VUP) ;EP - Log V UPDATED/REVIEWED entry for PROBLEM LIST UPDATED
N %,BQIDFN,APCDTCLA,APCDLOC,APCDDATE,APCDOLOC,APCDTYPE,APCDCAT,APCDTOPR,APCDLOOK,EPARMS,VFILE,RESULT,MSG
;
;Define VFILE
S BQIDFN=DFN S VFILE="BQIDFN="_BQIDFN
S APCDLOC=DUZ(2) S VFILE=VFILE_$C(28)_"APCDLOC="_APCDLOC
D NOW^%DTC S APCDDATE=$$FMTE^BQIUL1(%) S VFILE=VFILE_$C(28)_"APCDDATE="_APCDDATE
S APCDOLOC="" S VFILE=VFILE_$C(28)_"APCDOLOC="
S APCDTYPE="IHS" S VFILE=VFILE_$C(28)_"APCDTYPE="_APCDTYPE
S APCDCAT="EVENT (HISTORICAL)" S VFILE=VFILE_$C(28)_"APCDCAT="_APCDCAT
S APCDTOPR="" S VFILE=VFILE_$C(28)_"APCDTOPR="
;
;Define EPARMS
S APCDTCLA=$O(^AUTTCRA("B",VUP,"")) Q:APCDTCLA=""
S EPARMS="APCDTCLA="_APCDTCLA
S APCDLOOK=APCDTCLA S EPARMS=EPARMS_$C(28)_"APCDLOOK="_APCDLOOK
S APCDTCDT=$G(APCDTCDT,"") S EPARMS=EPARMS_$C(28)_"APCDTCDT="_APCDTCDT
S APCDTEPR=$G(APCDTEPR,"") S EPARMS=EPARMS_$C(28)_"APCDTEPR="_APCDTEPR
;
D EN^BQIVFADD("",BQIDFN,9000010.54,"Y",VFILE,EPARMS)
;
Q
;
EMSG ;
;;invalid dx, either not a valid ien, inactive code, E code
;;invalid patient dfn, either not a valid dfn or patient merged
;;invalid class code
;;error creating entry with FileMan
;;invalid date last modified
;;invalid provider narrative
;;invalid date entered
;;invalid facility
;invalid status
;invalid date of onset
Q
;
LOCK(DATA,DFN,PBIEN) ; EP - BQI LOCK PROBLEM
; Description
; Attempt to lock a problem record specified by PBIEN for
; exclusive editing access.
; This will only be used for edits and deletions of problem records.
; If successful, sets 'LAST LOCKED BY' with the current DUZ
; and returns a RESULT of 1 and the current DUZ.
; If unsuccessful, returns a RESULT of 0 and the DUZ from the
; 'LAST LOCKED BY' field.
; Input:
; DFN - Patient IEN
; PBIEN - Problem IEN to be locked
; Output:
; DATA = name of global (passed by reference) in which the data is stored
;
; RESULT = 1 if the lock succeeded
; = 0 if the lock failed
; = -1 if problem identified with file 90507 (shouldn't happen)
; USER = DUZ of the last user to successfully lock this panel
; or
; BMXSEC - if M error encountered
;
N UID,X,BQII,MSG,VAL,RESULT
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPBLK",UID))
K ^TMP("BQIPBLK",UID)
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
; Create header record
S BQII=0,@DATA@(BQII)="I00010RESULT^T00080MESSAGE"_$C(30)
;
S VAL=$$PBVAL(PBIEN,DFN),MSG=$P(VAL,U,2),VAL=$P(VAL,U)
I VAL=-1 S RESULT=-1 D SET Q
;
N USER
; Attempt lock and set RESULT accordingly
S RESULT=1
L +^AUPNPROB(PBIEN):1 E S RESULT=0
;
; If lock is unsuccessful, get 'LAST LOCKED BY' from the panel.
I RESULT=0 D
. ;S USER=$G(^XTMP("BQIPBLK",PTIEN))
. S USER=$G(^XTMP("BQIPBLK",PBIEN))
. S NAME=$$GET1^DIQ(200,USER,.01,"E")
. I NAME="" S NAME="an unknown user"
. S MSG="This record is currently being updated by "_NAME_"."
; If lock is successful, update 'LAST LOCKED BY' in ^XTMP.
I RESULT=1 D
. S ^XTMP("BQIPBLK",0)=$$FMADD^XLFDT(DT,1)_U_$$DT^XLFDT()_U_"Maintain locked by information for current locks of problem data"
. S ^XTMP("BQIPBLK",PBIEN)=DUZ
;
D SET
Q
;
UNLOCK(DATA,DFN,PBIEN) ; EP - BQI UNLOCK PROBLEM
; Description
; Unlock the problem record specified by PBIEN which was
; previously locked for exclusive editing access.
; If the entry in the 'LAST LOCKED BY' field is for this DUZ then
; delete it (so another user can't accidentally update it).
; Input:
; DFN - Patient IEN
; PBIEN - Problem IEN to be locked
; Output:
; DATA = name of global (passed by reference) in which the data is stored
; RESULT = 1 (unlock will always succeed)
; RESULT = -1 if problem identified with file 90507 (shouldn't happen)
; or
; BMXSEC - if M error encountered
;
N UID,X,BQII,MSG,REGIEN,RDATA,VAL
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPBLK",UID))
K ^TMP("BQIPBLK",UID)
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
; Create header record
S BQII=0,@DATA@(BQII)="I00010RESULT^T00080MESSAGE"_$C(30)
N RESULT,USER
S VAL=$$PBVAL(PBIEN,DFN),MSG=$P(VAL,U,2),VAL=$P(VAL,U)
I VAL=-1 S RESULT=-1 D SET Q
;
; Get 'LAST LOCKED BY'.
S USER=$G(^XTMP("BQIPBLK",PBIEN))
;
; If 'LAST LOCKED BY' is this DUZ then delete the lock entry from ^XTMP.
I USER=DUZ K ^XTMP("BQIPBLK",PBIEN)
;
; Unlock and set RESULT
S RESULT=1
L -^AUPNPROB(PBIEN)
D SET
Q
;
SET ; Report results
S BQII=BQII+1,@DATA@(BQII)=RESULT_"^"_MSG_$C(30)
S BQII=BQII+1,@DATA@(BQII)=$C(31)
Q
;
PBVAL(IEN,DFN) ; Validate problem ien
I IEN="" Q "-1^Invalid problem selected"
I $$GET1^DIQ(9000011,IEN_",",.02,"I")'=DFN Q "-1^Invalid problem selected"
Q 1
;
NOT(BQPIEN) ;EP - Return notes
S BQPRID=$$PID(BQPIEN)
S BQNOTE=""
S (BQCNT,BQDL)=0 F S BQDL=$O(^AUPNPROB(BQPIEN,11,BQDL)) Q:'BQDL D
. S NLOC=$P(^AUPNPROB(BQPIEN,11,BQDL,0),U,1)
. S BQNDX=0 F S BQNDX=$O(^AUPNPROB(BQPIEN,11,BQDL,11,BQNDX)) Q:'BQNDX D
.. S BQCNT=BQCNT+1
.. S BQNOTE=BQNOTE_BQPRID_$S($P($G(^AUTTLOC(NLOC,0)),U,7)]"":$P(^AUTTLOC(NLOC,0),U,7),1:"??")_$P($G(^AUPNPROB(BQPIEN,11,BQDL,11,BQNDX,0)),U)_" "
.. S BQNOTE=BQNOTE_$S($P($G(^AUPNPROB(BQPIEN,11,BQDL,11,BQNDX,0)),U,5)]"":$$FMTE^BQIUL1($P(^AUPNPROB(BQPIEN,11,BQDL,11,BQNDX,0),U,5)),1:" (no date on file)")_" "
.. S BQNOTE=BQNOTE_$P($G(^AUPNPROB(BQPIEN,11,BQDL,11,BQNDX,0)),U,3)_$C(13)_$C(10)
Q BQNOTE
;
PID(BQPIEN) ;EP - Return problem ID
NEW BQNDE0,LOC,BQPRID
S BQNDE0=$G(^AUPNPROB(BQPIEN,0))
S LOC=$P(BQNDE0,U,6)
S BQPRID=$S(LOC="":"??",$P($G(^AUTTLOC(LOC,0)),U,7)]"":$J($P(^AUTTLOC(LOC,0),U,7),4),1:"??")_$P(BQNDE0,U,7)
S BQPRID=$$TRIM^BQIUL1(BQPRID," ")
Q BQPRID
BQIRPL ;PRXM/HC/DLS - Patient Problem List ; 15 Jun 2008 8:09 PM
+1 ;;2.4;ICARE MANAGEMENT SYSTEM;;Apr 01, 2015;Build 41
+2 ;
+3 QUIT
+4 ;
EN(DATA,DFN,DRANGE,BQPIEN,DEL) ; EP - BQI PATIENT PROBLEM LIST
+1 ;Description
+2 ; Generates a Patient Problem List for a given DFN and Relative Date.
+3 ;
+4 ;Input
+5 ; DFN - Patient IEN
+6 ; DRANGE - Date to pull Patient Problem entered from (to the present).
+7 ; BQPIEN - Specific problem IEN
+8 ; DEL - "D" for deletes only, otherwise blank
+9 ;
+10 ;Output
+11 ; DATA - Name of global in which data is stored(^TMP("BQIRPL",UID))
+12 ;
+13 NEW UID,X,BQII,DA,IENS,BQIUPDT,LOC,BQAPID,BQID,BQIEN,SDATA
+14 NEW BQPRB,BQPRID,BQDX,BQST,BQONSET,BQNARR,BQNOTEF,BQCLS,NLOC
+15 NEW BQNDE0,BQCNT,BQDL,BQNOTE,BQNDX,BQPRBDT,BQPRV,BQSTN,BQIUSUP
+16 NEW BQICLAS,BQNIEN,HBQNARR,BQITCDT,BQITEPR
+17 ;
+18 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+19 SET DATA=$NAME(^TMP("BQIRPL",UID))
SET SDATA=$NAME(^TMP("BQISPL",UID))
+20 KILL @DATA,@SDATA
+21 ;
+22 SET BQII=0
+23 ;
+24 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER"
+25 ;
+26 SET BQPIEN=$GET(BQPIEN,"")
SET DFN=$GET(DFN,"")
SET DRANGE=$GET(DRANGE,"")
SET DEL=$GET(DEL,"")
+27 ;
+28 DO HDR
+29 ;
+30 IF DRANGE'=""
SET DRANGE=$$DATE^BQIUL1($GET(DRANGE))
+31 ;
+32 IF BQPIEN=""
IF DFN'=""
IF '$DATA(^AUPNPROB("AC",DFN))
GOTO DONE
+33 ;
+34 IF BQPIEN'=""
DO GETDATA(BQPIEN)
GOTO DONE
+35 ;
+36 FOR
SET BQPIEN=$ORDER(^AUPNPROB("AC",DFN,BQPIEN))
IF BQPIEN=""
QUIT
DO GETDATA(BQPIEN)
+37 ;
DONE ;
+1 SET BQST=""
+2 FOR
SET BQST=$ORDER(@SDATA@(BQST))
IF BQST=""
QUIT
Begin DoDot:1
+3 SET BQID=""
+4 FOR
SET BQID=$ORDER(@SDATA@(BQST,BQID))
IF BQID=""
QUIT
Begin DoDot:2
+5 SET BQIEN=""
+6 FOR
SET BQIEN=$ORDER(@SDATA@(BQST,BQID,BQIEN))
IF BQIEN=""
QUIT
Begin DoDot:3
+7 SET BQII=BQII+1
+8 SET @DATA@(BQII)=BQIEN_U_@SDATA@(BQST,BQID,BQIEN)_$CHAR(30)
End DoDot:3
End DoDot:2
End DoDot:1
+9 SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(31)
+10 KILL @SDATA
+11 QUIT
+12 ;
GETDATA(BQPIEN) ;EP
+1 ;
+2 SET DA=BQPIEN
+3 SET IENS=$$IENS^DILF(.DA)
+4 SET BQPRBDT=$$GET1^DIQ(9000011,IENS,".08","I")
+5 IF DRANGE'=""
IF BQPRBDT<DRANGE
QUIT
+6 SET BQPRBDT=$$FMTE^BQIUL1(BQPRBDT)
+7 ;
+8 SET BQCLS=$$GET1^DIQ(9000011,IENS,.04,"I")_$CHAR(28)_$$GET1^DIQ(9000011,IENS,.04,"E")
+9 SET BQNDE0=$GET(^AUPNPROB(BQPIEN,0))
+10 SET LOC=$PIECE(BQNDE0,U,6)
+11 SET BQPRID=$SELECT(LOC="":"??",$PIECE($GET(^AUTTLOC(LOC,0)),U,7)]"":$JUSTIFY($PIECE(^AUTTLOC(LOC,0),U,7),4),1:"??")_$PIECE(BQNDE0,U,7)
+12 SET BQAPID=$SELECT(LOC="":"??",$PIECE($GET(^AUTTLOC(LOC,0)),U,7)]"":$JUSTIFY($PIECE(^AUTTLOC(LOC,0),U,7),4),1:"??")_$EXTRACT("0000",1,4-$LENGTH($PIECE(BQNDE0,U,7)))_$PIECE(BQNDE0,U,7)
+13 ; Code set versioning
IF $$VERSION^XPDUTL("BCSV")
SET BQDX=$$ICD9^BQIUL3($PIECE(BQNDE0,U),,2)
+14 IF '$$VERSION^XPDUTL("BCSV")
SET BQDX=$PIECE(^ICD9($PIECE(BQNDE0,U),0),U)
+15 IF BQDX'=""
IF $$VERSION^XPDUTL("BCSV")
SET BQDX=$PIECE(BQNDE0,U)_$CHAR(28)_BQDX_" - "_$$ICD9^BQIUL3($PIECE(BQNDE0,U),,4)
+16 IF BQDX'=""
IF '$$VERSION^XPDUTL("BCSV")
SET BQDX=$PIECE(BQNDE0,U)_$CHAR(28)_BQDX_" - "_$PIECE(^ICD9($PIECE(BQNDE0,U),0),U,3)
+17 ;
+18 SET BQST=$$GET1^DIQ(9000011,BQPIEN_",",.12,"E")
+19 SET BQSTN=$$GET1^DIQ(9000011,BQPIEN_",",.12,"I")
+20 SET BQONSET=$$FMTE^BQIUL1($PIECE($GET(BQNDE0),U,13))
+21 SET BQIUPDT=$$FMTE^BQIUL1($PIECE($GET(BQNDE0),U,3))
+22 SET BQIUSUP=$$GET1^DIQ(9000011,BQPIEN_",",.14,"E")
+23 SET (BQITCDT,BQITEPR)=""
+24 IF DEL'="D"
Begin DoDot:1
+25 SET BQITCDT=$$LASTPLU^APCLAPI6(DFN,,DT,"A")
+26 ;
+27 ;Pull time from entry if not defined (current API doesnt return time)
+28 IF $PIECE($PIECE(BQITCDT,U),".",2)=""
Begin DoDot:2
+29 NEW IEN,DTM
+30 SET IEN=$PIECE(BQITCDT,U,6)
IF IEN=""
QUIT
+31 SET DTM=$$GET1^DIQ(9000010.54,IEN_",",1201,"I")
+32 IF DTM["."
SET $PIECE(BQITCDT,U)=DTM
End DoDot:2
+33 ;
+34 SET BQITEPR=$PIECE(BQITCDT,U,3)_$CHAR(28)_$$GET1^DIQ(200,$PIECE(BQITCDT,U,3)_",",.01,"E")
SET BQITCDT=$$FMTE^BQIUL1($PIECE(BQITCDT,U))
End DoDot:1
+35 ;S:BQIUSUP="" BQIUSUP=$$GET1^DIQ(9000011,BQPIEN_",",1.03,"E")
+36 SET BQICLAS=""
+37 IF $GET(^DD(9000011,.15,0))'=""
Begin DoDot:1
+38 SET BQICLAS=$$GET1^DIQ(9000011,BQPIEN_",",.15,"I")_$CHAR(28)_$$GET1^DIQ(9000011,BQPIEN_",",.15,"E")
End DoDot:1
+39 SET BQNARR=$PIECE($GET(^AUTNPOV(+$PIECE(BQNDE0,U,5),0)),U)
SET BQNIEN=+$PIECE(BQNDE0,U,5)
+40 SET HBQNARR=BQNIEN
+41 IF $$PATCH^XPDUTL("BJPC*2.0*10")
SET BQNARR=$$PNPROB^AUPNVUTL(BQNIEN)
+42 SET BQNOTE=$$NOT(BQPIEN)
+43 IF LOC'=""
SET LOC=LOC_$CHAR(28)_$$GET1^DIQ(9999999.06,LOC_",",.01,"E")
+44 SET BQST=$SELECT(BQST="":"UNKNOWN",1:BQST)
+45 SET @SDATA@(BQST,BQAPID,BQPIEN)=BQPRID_U_BQPRBDT_U_LOC_U_BQIUSUP_U_BQIUPDT_U_BQDX_U_BQCLS_U_$GET(BQSTN)_$CHAR(28)_BQST_U_BQONSET_U_HBQNARR_U_BQNARR_U_BQNOTE_U_BQICLAS_U_DFN_U_BQITCDT_U_BQITEPR
+46 QUIT
+47 ;
HDR ;
+1 SET @DATA@(BQII)="I00010PBLIEN^T00004PBLID^D00015APCDDTE^T00030APCDFAC^T00050BQIUSLM^D00015APCDDLM^T00007APCDDX^T00020APCDCLS^T00008APCDSTAT^D00015APCDDOO^T00080APCDN^"
+2 SET @DATA@(BQII)=@DATA@(BQII)_"T00080PRVNAR^T01024PBLNOTES^T00030APCDCLAS^I00010DFN^D00030APCDTCDT^T00035APCDTEPR"_$CHAR(30)
+3 QUIT
+4 ;
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(BQII)
IF $DATA(DATA)
SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(31)
+6 QUIT
+7 ;
UPD(DATA,DFN,TYPE,PBLIEN,PARMS) ;EP - BQI UPDATE PROBLEM LIST
+1 ;Input
+2 ; DFN - Patient internal entry number
+3 ; TYPE - 'A' to add or 'D' to delete
+4 ; PBLIEN - Problem IEN
+5 ; PARMS - Data values
+6 ;
+7 NEW UID,II,APCDCLS,APCDDLM,APCDDOO,APCDDTE,APCDDX,APCDFAC,APCDP,APCDSTAT
+8 NEW PBLPR,PBLNB,PBLID,PRVNAR,APCDCLAS,APCDEBU,APCDN,BN,BQ,BQIDATA,CHIEN
+9 NEW FIELD,FILE,FNME,VFIEN,RESULT,LIST,PDATA,NAME,VALUE,PFIEN,PTYP,MSG,ERROR
+10 NEW APCDP,VER,NM,QFL,BQIUPD,APCDTCDT,APCDTEPR,APCDEC1,APCDEC2,APCDEC3
+11 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+12 SET DATA=$NAME(^TMP("BQIRPLU",UID))
+13 KILL @DATA
+14 ;
+15 SET BQII=0
+16 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER"
+17 SET @DATA@(BQII)="I00010RESULT^T01024MSG^I00010PBLIEN"_$CHAR(30)
+18 SET VFIEN=$ORDER(^BQI(90506.3,"B","Problem List",""))
+19 IF VFIEN=""
SET BMXSEC="RPC Call Failed: Problem List Definition does not exist."
QUIT
+20 SET FILE=$PIECE(^BQI(90506.3,VFIEN,0),U,2)
+21 ;
+22 SET TYPE=$GET(TYPE,"")
SET PBLIEN=$GET(PBLIEN,"")
+23 IF TYPE="D"
Begin DoDot:1
+24 SET RESULT=$$DELPROB^APCDALV2(PBLIEN)
SET MSG=""
+25 SET RESULT=$SELECT(RESULT="":1,1:RESULT)
+26 IF RESULT=-1
SET MSG="Unable to delete Problem"
+27 SET RESULT=RESULT_U_MSG
End DoDot:1
GOTO DNE
+28 ;
+29 SET PARMS=$GET(PARMS,"")
+30 IF PARMS=""
Begin DoDot:1
+31 SET LIST=""
SET BN=""
+32 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+33 KILL PARMS
+34 SET PARMS=LIST
+35 KILL LIST
End DoDot:1
+36 ;
+37 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+38 NEW EXEC
+39 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+40 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
IF VALUE=""
QUIT
+41 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
+42 SET PTYP=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
+43 IF PTYP="D"!(PTYP="A")
SET VALUE=$$DATE^BQIUL1(VALUE)
+44 ;I PTYP="T" S VALUE=VALUE
+45 IF PTYP="C"
Begin DoDot:2
+46 SET CHIEN=$ORDER(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,""))
IF CHIEN=""
QUIT
+47 SET VALUE=$PIECE(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
End DoDot:2
+48 SET FIELD=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
+49 SET EXEC=$GET(^BQI(90506.3,VFIEN,10,PFIEN,7))
+50 IF EXEC'=""
XECUTE EXEC
QUIT
+51 IF TYPE="A"
Begin DoDot:2
+52 SET @NAME=VALUE
SET BQIDATA(NAME)=FIELD
End DoDot:2
+53 IF TYPE="E"
SET BQIUPD(FILE,PBLIEN_",",FIELD)=VALUE
SET @NAME=VALUE
End DoDot:1
+54 ;
+55 IF TYPE="E"
Begin DoDot:1
+56 IF $DATA(BQIUPD)
SET BQIUPD(FILE,PBLIEN_",",.14)=DUZ
SET BQIUPD(FILE,PBLIEN_",",.03)=DT
+57 IF $GET(APCDCLAS)=""
IF $PIECE(^AUPNPROB(PBLIEN,0),U,15)'=""
SET BQIUPD(FILE,PBLIEN_",",.15)="@"
+58 DO FILE^DIE("","BQIUPD","ERROR")
+59 KILL BQIUPD
+60 SET RESULT=1_U
+61 IF $DATA(ERROR)>0
SET RESULT=-1_U_$GET(ERROR("DIERR","1","TEXT","1"))
End DoDot:1
+62 ;
+63 IF TYPE="A"
Begin DoDot:1
+64 SET APCDP=DFN
+65 SET FNME="APC"
+66 FOR
SET FNME=$ORDER(^BQI(90506.3,VFIEN,10,"AC",FNME))
IF FNME=""!($EXTRACT(FNME,1,3)'="APC")
QUIT
Begin DoDot:2
+67 SET @FNME=$GET(@FNME,"")
End DoDot:2
+68 ;
+69 SET VER=$$VERSION^XPDUTL("BJPC")
+70 IF VER<2.0
Begin DoDot:2
+71 IF $$PATCH^XPDUTL("BJPC*1.0*1")
SET RESULT=$$ADDPROB^APCDALV2("`"_APCDDX,APCDP,APCDDLM,APCDCLS,PRVNAR,APCDFAC,APCDDTE,APCDSTAT,APCDDOO)
QUIT
+72 IF $$PATCH^XPDUTL("BJPC*1.0*2")
SET RESULT=$$ADDPROB^APCDALV2("`"_APCDDX,APCDP,APCDDLM,APCDCLS,"`"_APCDN,APCDFAC,APCDDTE,APCDSTAT,APCDDOO)
End DoDot:2
+73 IF VER>1.0
Begin DoDot:2
+74 IF $GET(APCDDOO)'=""
SET APCDDOO=$$FMTE^XLFDT(APCDDOO,1)
+75 SET RESULT=$$ADDPROB^APCDALV2("`"_APCDDX,APCDP,APCDDLM,APCDCLS,"`"_APCDN,APCDFAC,APCDDTE,APCDSTAT,APCDDOO,APCDCLAS,$GET(APCDEBU),$GET(APCDEC1),$GET(APCDEC2),$GET(APCDEC3))
End DoDot:2
+76 SET MSG=$PIECE($TEXT(EMSG+RESULT),";;",2)
+77 IF RESULT
Begin DoDot:2
+78 SET IEN=""
SET QFL=0
+79 FOR
SET IEN=$ORDER(^AUPNPROB("AC",DFN,IEN),-1)
IF IEN=""!QFL
QUIT
Begin DoDot:3
+80 IF $PIECE(^AUPNPROB(IEN,0),U)=APCDDX
IF $PIECE($GET(^AUPNPROB(IEN,1)),U,3)=DUZ
SET PBLIEN=IEN
SET QFL=1
End DoDot:3
+81 IF $GET(PBLIEN)'=""
Begin DoDot:3
+82 SET BQIUPD(FILE,PBLIEN_",",.14)=DUZ
+83 IF $GET(APCDCLAS)=""
IF $PIECE(^AUPNPROB(PBLIEN,0),U,15)'=""
SET BQIUPD(FILE,PBLIEN_",",.15)="@"
End DoDot:3
+84 DO FILE^DIE("","BQIUPD","ERROR")
+85 KILL BQIUPD
End DoDot:2
+86 IF 'RESULT
Begin DoDot:2
+87 NEW IEN
+88 SET IEN=""
SET QFL=0
+89 FOR
SET IEN=$ORDER(^AUPNPROB("AC",DFN,IEN),-1)
IF IEN=""!(QFL)
QUIT
Begin DoDot:3
+90 IF $PIECE(^AUPNPROB(IEN,0),U,1)'=APCDDX
QUIT
+91 IF $PIECE($GET(^AUPNPROB(IEN,1)),U,3)=DUZ
SET QFL=1
SET PBLIEN=IEN
+92 SET NM="PBL"
+93 FOR
SET NM=$ORDER(BQIDATA(NM))
IF NM=""!($EXTRACT(NM,1,3)'="PBL")
QUIT
Begin DoDot:4
+94 SET FIELD=BQIDATA(NM)
SET BQIUPD(FILE,PBLIEN_",",FIELD)=$GET(@NM)
End DoDot:4
+95 SET BQIUPD(FILE,PBLIEN_",",.14)=DUZ
+96 DO FILE^DIE("","BQIUPD","ERROR")
+97 KILL BQIUPD
End DoDot:3
End DoDot:2
+98 SET RESULT=$SELECT(RESULT>0:-1,1:1)_U_MSG
End DoDot:1
+99 ;
+100 ;Log V UPDATED/REVIEWED (Updated) entry
DNE ; EP
+1 IF +RESULT=1
DO VUP("PROBLEM LIST UPDATED")
+2 ;
+3 SET BQII=BQII+1
SET @DATA@(BQII)=RESULT_U_$GET(PBLIEN)_$CHAR(30)
+4 SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(31)
+5 QUIT
+6 ;
VUP(VUP) ;EP - Log V UPDATED/REVIEWED entry for PROBLEM LIST UPDATED
+1 NEW %,BQIDFN,APCDTCLA,APCDLOC,APCDDATE,APCDOLOC,APCDTYPE,APCDCAT,APCDTOPR,APCDLOOK,EPARMS,VFILE,RESULT,MSG
+2 ;
+3 ;Define VFILE
+4 SET BQIDFN=DFN
SET VFILE="BQIDFN="_BQIDFN
+5 SET APCDLOC=DUZ(2)
SET VFILE=VFILE_$CHAR(28)_"APCDLOC="_APCDLOC
+6 DO NOW^%DTC
SET APCDDATE=$$FMTE^BQIUL1(%)
SET VFILE=VFILE_$CHAR(28)_"APCDDATE="_APCDDATE
+7 SET APCDOLOC=""
SET VFILE=VFILE_$CHAR(28)_"APCDOLOC="
+8 SET APCDTYPE="IHS"
SET VFILE=VFILE_$CHAR(28)_"APCDTYPE="_APCDTYPE
+9 SET APCDCAT="EVENT (HISTORICAL)"
SET VFILE=VFILE_$CHAR(28)_"APCDCAT="_APCDCAT
+10 SET APCDTOPR=""
SET VFILE=VFILE_$CHAR(28)_"APCDTOPR="
+11 ;
+12 ;Define EPARMS
+13 SET APCDTCLA=$ORDER(^AUTTCRA("B",VUP,""))
IF APCDTCLA=""
QUIT
+14 SET EPARMS="APCDTCLA="_APCDTCLA
+15 SET APCDLOOK=APCDTCLA
SET EPARMS=EPARMS_$CHAR(28)_"APCDLOOK="_APCDLOOK
+16 SET APCDTCDT=$GET(APCDTCDT,"")
SET EPARMS=EPARMS_$CHAR(28)_"APCDTCDT="_APCDTCDT
+17 SET APCDTEPR=$GET(APCDTEPR,"")
SET EPARMS=EPARMS_$CHAR(28)_"APCDTEPR="_APCDTEPR
+18 ;
+19 DO EN^BQIVFADD("",BQIDFN,9000010.54,"Y",VFILE,EPARMS)
+20 ;
+21 QUIT
+22 ;
EMSG ;
+1 ;;invalid dx, either not a valid ien, inactive code, E code
+2 ;;invalid patient dfn, either not a valid dfn or patient merged
+3 ;;invalid class code
+4 ;;error creating entry with FileMan
+5 ;;invalid date last modified
+6 ;;invalid provider narrative
+7 ;;invalid date entered
+8 ;;invalid facility
+9 ;invalid status
+10 ;invalid date of onset
+11 QUIT
+12 ;
LOCK(DATA,DFN,PBIEN) ; EP - BQI LOCK PROBLEM
+1 ; Description
+2 ; Attempt to lock a problem record specified by PBIEN for
+3 ; exclusive editing access.
+4 ; This will only be used for edits and deletions of problem records.
+5 ; If successful, sets 'LAST LOCKED BY' with the current DUZ
+6 ; and returns a RESULT of 1 and the current DUZ.
+7 ; If unsuccessful, returns a RESULT of 0 and the DUZ from the
+8 ; 'LAST LOCKED BY' field.
+9 ; Input:
+10 ; DFN - Patient IEN
+11 ; PBIEN - Problem IEN to be locked
+12 ; Output:
+13 ; DATA = name of global (passed by reference) in which the data is stored
+14 ;
+15 ; RESULT = 1 if the lock succeeded
+16 ; = 0 if the lock failed
+17 ; = -1 if problem identified with file 90507 (shouldn't happen)
+18 ; USER = DUZ of the last user to successfully lock this panel
+19 ; or
+20 ; BMXSEC - if M error encountered
+21 ;
+22 NEW UID,X,BQII,MSG,VAL,RESULT
+23 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+24 SET DATA=$NAME(^TMP("BQIPBLK",UID))
+25 KILL ^TMP("BQIPBLK",UID)
+26 ;
+27 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER"
+28 ;
+29 ; Create header record
+30 SET BQII=0
SET @DATA@(BQII)="I00010RESULT^T00080MESSAGE"_$CHAR(30)
+31 ;
+32 SET VAL=$$PBVAL(PBIEN,DFN)
SET MSG=$PIECE(VAL,U,2)
SET VAL=$PIECE(VAL,U)
+33 IF VAL=-1
SET RESULT=-1
DO SET
QUIT
+34 ;
+35 NEW USER
+36 ; Attempt lock and set RESULT accordingly
+37 SET RESULT=1
+38 LOCK +^AUPNPROB(PBIEN):1
IF '$TEST
SET RESULT=0
+39 ;
+40 ; If lock is unsuccessful, get 'LAST LOCKED BY' from the panel.
+41 IF RESULT=0
Begin DoDot:1
+42 ;S USER=$G(^XTMP("BQIPBLK",PTIEN))
+43 SET USER=$GET(^XTMP("BQIPBLK",PBIEN))
+44 SET NAME=$$GET1^DIQ(200,USER,.01,"E")
+45 IF NAME=""
SET NAME="an unknown user"
+46 SET MSG="This record is currently being updated by "_NAME_"."
End DoDot:1
+47 ; If lock is successful, update 'LAST LOCKED BY' in ^XTMP.
+48 IF RESULT=1
Begin DoDot:1
+49 SET ^XTMP("BQIPBLK",0)=$$FMADD^XLFDT(DT,1)_U_$$DT^XLFDT()_U_"Maintain locked by information for current locks of problem data"
+50 SET ^XTMP("BQIPBLK",PBIEN)=DUZ
End DoDot:1
+51 ;
+52 DO SET
+53 QUIT
+54 ;
UNLOCK(DATA,DFN,PBIEN) ; EP - BQI UNLOCK PROBLEM
+1 ; Description
+2 ; Unlock the problem record specified by PBIEN which was
+3 ; previously locked for exclusive editing access.
+4 ; If the entry in the 'LAST LOCKED BY' field is for this DUZ then
+5 ; delete it (so another user can't accidentally update it).
+6 ; Input:
+7 ; DFN - Patient IEN
+8 ; PBIEN - Problem IEN to be locked
+9 ; Output:
+10 ; DATA = name of global (passed by reference) in which the data is stored
+11 ; RESULT = 1 (unlock will always succeed)
+12 ; RESULT = -1 if problem identified with file 90507 (shouldn't happen)
+13 ; or
+14 ; BMXSEC - if M error encountered
+15 ;
+16 NEW UID,X,BQII,MSG,REGIEN,RDATA,VAL
+17 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+18 SET DATA=$NAME(^TMP("BQIPBLK",UID))
+19 KILL ^TMP("BQIPBLK",UID)
+20 ;
+21 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER"
+22 ;
+23 ; Create header record
+24 SET BQII=0
SET @DATA@(BQII)="I00010RESULT^T00080MESSAGE"_$CHAR(30)
+25 NEW RESULT,USER
+26 SET VAL=$$PBVAL(PBIEN,DFN)
SET MSG=$PIECE(VAL,U,2)
SET VAL=$PIECE(VAL,U)
+27 IF VAL=-1
SET RESULT=-1
DO SET
QUIT
+28 ;
+29 ; Get 'LAST LOCKED BY'.
+30 SET USER=$GET(^XTMP("BQIPBLK",PBIEN))
+31 ;
+32 ; If 'LAST LOCKED BY' is this DUZ then delete the lock entry from ^XTMP.
+33 IF USER=DUZ
KILL ^XTMP("BQIPBLK",PBIEN)
+34 ;
+35 ; Unlock and set RESULT
+36 SET RESULT=1
+37 LOCK -^AUPNPROB(PBIEN)
+38 DO SET
+39 QUIT
+40 ;
SET ; Report results
+1 SET BQII=BQII+1
SET @DATA@(BQII)=RESULT_"^"_MSG_$CHAR(30)
+2 SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(31)
+3 QUIT
+4 ;
PBVAL(IEN,DFN) ; Validate problem ien
+1 IF IEN=""
QUIT "-1^Invalid problem selected"
+2 IF $$GET1^DIQ(9000011,IEN_",",.02,"I")'=DFN
QUIT "-1^Invalid problem selected"
+3 QUIT 1
+4 ;
NOT(BQPIEN) ;EP - Return notes
+1 SET BQPRID=$$PID(BQPIEN)
+2 SET BQNOTE=""
+3 SET (BQCNT,BQDL)=0
FOR
SET BQDL=$ORDER(^AUPNPROB(BQPIEN,11,BQDL))
IF 'BQDL
QUIT
Begin DoDot:1
+4 SET NLOC=$PIECE(^AUPNPROB(BQPIEN,11,BQDL,0),U,1)
+5 SET BQNDX=0
FOR
SET BQNDX=$ORDER(^AUPNPROB(BQPIEN,11,BQDL,11,BQNDX))
IF 'BQNDX
QUIT
Begin DoDot:2
+6 SET BQCNT=BQCNT+1
+7 SET BQNOTE=BQNOTE_BQPRID_$SELECT($PIECE($GET(^AUTTLOC(NLOC,0)),U,7)]"":$PIECE(^AUTTLOC(NLOC,0),U,7),1:"??")_$PIECE($GET(^AUPNPROB(BQPIEN,11,BQDL,11,BQNDX,0)),U)_" "
+8 SET BQNOTE=BQNOTE_$SELECT($PIECE($GET(^AUPNPROB(BQPIEN,11,BQDL,11,BQNDX,0)),U,5)]"":$$FMTE^BQIUL1($PIECE(^AUPNPROB(BQPIEN,11,BQDL,11,BQNDX,0),U,5)),1:" (no date on file)")_" "
+9 SET BQNOTE=BQNOTE_$PIECE($GET(^AUPNPROB(BQPIEN,11,BQDL,11,BQNDX,0)),U,3)_$CHAR(13)_$CHAR(10)
End DoDot:2
End DoDot:1
+10 QUIT BQNOTE
+11 ;
PID(BQPIEN) ;EP - Return problem ID
+1 NEW BQNDE0,LOC,BQPRID
+2 SET BQNDE0=$GET(^AUPNPROB(BQPIEN,0))
+3 SET LOC=$PIECE(BQNDE0,U,6)
+4 SET BQPRID=$SELECT(LOC="":"??",$PIECE($GET(^AUTTLOC(LOC,0)),U,7)]"":$JUSTIFY($PIECE(^AUTTLOC(LOC,0),U,7),4),1:"??")_$PIECE(BQNDE0,U,7)
+5 SET BQPRID=$$TRIM^BQIUL1(BQPRID," ")
+6 QUIT BQPRID
