BQIRPL.m

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