BQIRPLN ;VANGENT/HC/ALA-Problem List Notes ; 08 May 2008 4:59 PM
;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66
;
;
EN(DATA,BQPIEN) ;EP - BQI PATIENT PROBLEM NOTES
;Input
; BQPIEN - Specific problem IEN
;
;Output
; DATA - Name of global in which data is stored
;
NEW II,UID,BQDL,LOCN,LOC,NN,PBNIEN,PBNTNB,PBNNAR,PBNSTN,PBNSTAT
NEW PBNDT,PBNUSN,PBNUSR
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIRPLN",UID))
K @DATA
;
S II=0
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S BQPIEN=$G(BQPIEN,"") I BQPIEN="" S BMXSEC="No problem identified" Q
;
S @DATA@(II)="I00010PBNIEN^T00030APCDFAC^T00010PBNTNB^T00060PBNNAR^T00001PBNSTAT^D00015PBNDT^T00035PBNUSR"_$C(30)
;
S BQDL=0
F S BQDL=$O(^AUPNPROB(BQPIEN,11,BQDL)) Q:'BQDL D
. NEW DA,IENS
. S DA(1)=BQPIEN,DA=BQDL,IENS=$$IENS^DILF(.DA)
. S LOCN=$$GET1^DIQ(9000011.11,IENS,.01,"I")
. I LOCN'="" S LOC=LOCN_$C(28)_$$GET1^DIQ(9000011.11,IENS,.01,"E")
. S NN=0
. F S NN=$O(^AUPNPROB(BQPIEN,11,BQDL,11,NN)) Q:'NN D
.. NEW DA,IENS
.. S DA(2)=BQPIEN,DA(1)=BQDL,DA=NN,IENS=$$IENS^DILF(.DA)
.. S PBNIEN=NN
.. S PBNTNB=$$GET1^DIQ(9000011.1111,IENS,.01,"E")
.. S PBNNAR=$P(^AUPNPROB(BQPIEN,11,BQDL,11,NN,0),U,3)
.. ;S PBNNAR=$$STRIP^XLFSTR(PBNNAR,$C(13))
.. ;S PBNNAR=$TR(PBNNAR,$C(10)," ")
.. S PBNSTN=$$GET1^DIQ(9000011.1111,IENS,.04,"I")
.. I PBNSTN'="" S PBNSTAT=PBNSTN_$C(28)_$$GET1^DIQ(9000011.1111,IENS,.04,"E")
.. S PBNDT=$$GET1^DIQ(9000011.1111,IENS,.05,"I")
.. S PBNUSN=$$GET1^DIQ(9000011.1111,IENS,.06,"I")
.. I PBNUSN'="" S PBNUSR=PBNUSN_$C(28)_$$GET1^DIQ(9000011.1111,IENS,.06,"E")
.. S II=II+1,@DATA@(II)=PBNIEN_U_$G(LOC)_U_$G(PBNTNB)_U_$G(PBNNAR)_U_$G(PBNSTAT)_U_$$FMTE^BQIUL1(PBNDT)_U_$G(PBNUSR)_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
UPD(DATA,PBLIEN,PBNIEN,PARMS) ; EP - BQI UPDATE PROBLEM NOTE
NEW UID,II,VFIEN,FILE,LIST,BN,PDATA,NAME,VALUE,PFIEN,PTYP,CHIEN,FIELD,BQIUPD,FACN
NEW PBNTNB,RESULT,ERROR,BQ,APCDFAC
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIRPLNU",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="I00010RESULT^T01024MSG"_$C(30)
S VFIEN=$O(^BQI(90506.3,"B","Problem Notes",""))
I VFIEN="" S BMXSEC="RPC Call Failed: Problem Notes Definition does not exist." Q
S FILE=$P(^BQI(90506.3,VFIEN,0),U,2)
;
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
. 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)
. I FIELD'="" S BQIUPD(FILE,1_",",FIELD)=VALUE
. S @NAME=VALUE
;
S FACN=""
I $G(APCDFAC)="" S FACN=$O(^AUPNPROB(PBLIEN,11,"B",DUZ(2),""))
I $G(APCDFAC)'="" S FACN=$O(^AUPNPROB(PBLIEN,11,"B",APCDFAC,""))
I FACN="" D
. NEW DA,DIC,DLAYGO,Y,X
. S DA(1)=PBLIEN
. S DIC(0)="LN",DLAYGO=9000011.11,DIC("P")=DLAYGO,DIC="^AUPNPROB("_DA(1)_",11,",X=DUZ(2)
. K DO,DD D FILE^DICN
. S FACN=+Y
;
I $G(PBNIEN)="" D
. NEW DA,DIC,DLAYGO,Y,X
. S DA(2)=PBLIEN,DA(1)=FACN
. S DIC(0)="LN",DLAYGO=9000011.1111,DIC("P")=DLAYGO,DIC="^AUPNPROB("_DA(2)_",11,"_DA(1)_",11,"
. S X=PBNTNB
. K DO,DD D FILE^DICN
. S PBNIEN=+Y
;
NEW DA,IENS,BQIUPDT
S DA(2)=PBLIEN,DA(1)=FACN,DA=PBNIEN,IENS=$$IENS^DILF(.DA)
M BQIUPDT(FILE,IENS)=BQIUPD(FILE,1_",")
K BQIUPD
D FILE^DIE("","BQIUPDT","ERROR")
S RESULT=1_U
I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR","1","TEXT","1"))
S II=II+1,@DATA@(II)=RESULT_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
PLR(DATA,DFN,PARMS) ;EP - BQI UPDATE PRB LIST REV
;
NEW UID,II,APCDTCDT,APCDTEPR,LIST,BN,VFIEN
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIRPLN",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="I00010RESULT^T01024MSG"_$C(30)
;
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
;
S VFIEN=$O(^BQI(90506.3,"B","Prob List Reviewed","")) I VFIEN="" S BMXSEC="Error locating Prob List Reviewed" G XPLR
;
F BQ=1:1:$L(PARMS,$C(28)) D
. N PDATA,NAME,VALUE,PFIEN,PTYP
. 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)
. S @NAME=VALUE
;
;Log V UPDATED/REVIEWED (Updated) entry
D VUP^BQIRPL("PROBLEM LIST REVIEWED")
S II=II+1,@DATA@(II)=$P($G(^TMP("BQIVFADD",$J,1)),U)_U_$C(30)
K ^TMP("BQIVFADD",$J)
;
XPLR S II=II+1,@DATA@(II)=$C(31)
Q
;
NAP(DATA,DFN,PARMS) ;EP - BQI UPDATE NO ACTIVE PRB
;
NEW UID,II,APCDTCDT,APCDTEPR,LIST,BN,VFIEN
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIRPLN",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="I00010RESULT^T01024MSG"_$C(30)
;
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
;
S VFIEN=$O(^BQI(90506.3,"B","No Active Problems","")) I VFIEN="" S BMXSEC="Error locating No Active Problems" G XNAP
;
F BQ=1:1:$L(PARMS,$C(28)) D
. N PDATA,NAME,VALUE,PFIEN,PTYP
. 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)
. S @NAME=VALUE
;
;Log V UPDATED/REVIEWED (Updated) entry
D VUP^BQIRPL("NO ACTIVE PROBLEMS")
S II=II+1,@DATA@(II)=$P($G(^TMP("BQIVFADD",$J,1)),U)_U_$C(30)
K ^TMP("BQIVFADD",$J)
;
XNAP S II=II+1,@DATA@(II)=$C(31)
Q
;
DPLR(DATA,DFN) ;EP - BQI DISPLAY PRB LIST REV
;
NEW UID,II,APCDTCDT,APCDTEPR
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIRPLN",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="I00010DFN^D00030APCDTCDT^T00035APCDTEPR"_$C(30)
;
S APCDTCDT=$$LASTPLR^APCLAPI6(DFN,,DT,"A")
S APCDTEPR=$P(APCDTCDT,U,3)_$C(28)_$$GET1^DIQ(200,$P(APCDTCDT,U,3)_",",.01,"E"),APCDTCDT=$$FMTE^BQIUL1($P(APCDTCDT,U))
;
S II=II+1,@DATA@(II)=DFN_U_APCDTCDT_U_APCDTEPR_$C(30)
;
XDPLR S II=II+1,@DATA@(II)=$C(31)
Q
;
DNAP(DATA,DFN) ;EP - BQI DISPLAY NO ACTIVE PRB
;
NEW UID,II,APCDTCDT,APCDTEPR
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIRPLN",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="I00010DFN^D00030APCDTCDT^T00035APCDTEPR"_$C(30)
;
S APCDTCDT=$$LASTPLR^APCLAPI6(DFN,,DT,"A")
S APCDTEPR=$P(APCDTCDT,U,3)_$C(28)_$$GET1^DIQ(200,$P(APCDTCDT,U,3)_",",.01,"E"),APCDTCDT=$$FMTE^BQIUL1($P(APCDTCDT,U))
;
S II=II+1,@DATA@(II)=DFN_U_APCDTCDT_U_APCDTEPR_$C(30)
;
XDNAP S II=II+1,@DATA@(II)=$C(31)
Q
;
PLACT(DATA,DFN) ;EP - BQI ACTIVE PROBLEM LIST
;
NEW UID,II,ACTIVE,PRBIEN,RESULT,SDATA
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIRPLN",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="I00001ACTIVE"_$C(30)
;
S RESULT=0,SDATA=$P($G(^DD(9000011,.12,0)),U,3)
S PRBIEN="" F S PRBIEN=$O(^AUPNPROB("AC",DFN,PRBIEN)) Q:PRBIEN="" D Q:RESULT
. ;
. ;Pull the status of the problem
. S ACTIVE=$$GET1^DIQ(9000011,PRBIEN_",",.12,"I")
. I SDATA["ACTIVE",ACTIVE="A" S RESULT=1 Q
. I SDATA["CHRONIC" D
.. S RESULT=1
.. I ACTIVE="D"!(ACTIVE="I") S RESULT=0 Q
;
S II=II+1,@DATA@(II)=RESULT_$C(30)
;
XPLACT S II=II+1,@DATA@(II)=$C(31)
Q
BQIRPLN ;VANGENT/HC/ALA-Problem List Notes ; 08 May 2008 4:59 PM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66
+2 ;
+3 ;
EN(DATA,BQPIEN) ;EP - BQI PATIENT PROBLEM NOTES
+1 ;Input
+2 ; BQPIEN - Specific problem IEN
+3 ;
+4 ;Output
+5 ; DATA - Name of global in which data is stored
+6 ;
+7 NEW II,UID,BQDL,LOCN,LOC,NN,PBNIEN,PBNTNB,PBNNAR,PBNSTN,PBNSTAT
+8 NEW PBNDT,PBNUSN,PBNUSR
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("BQIRPLN",UID))
+11 KILL @DATA
+12 ;
+13 SET II=0
+14 ;
+15 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER"
+16 ;
+17 SET BQPIEN=$GET(BQPIEN,"")
IF BQPIEN=""
SET BMXSEC="No problem identified"
QUIT
+18 ;
+19 SET @DATA@(II)="I00010PBNIEN^T00030APCDFAC^T00010PBNTNB^T00060PBNNAR^T00001PBNSTAT^D00015PBNDT^T00035PBNUSR"_$CHAR(30)
+20 ;
+21 SET BQDL=0
+22 FOR
SET BQDL=$ORDER(^AUPNPROB(BQPIEN,11,BQDL))
IF 'BQDL
QUIT
Begin DoDot:1
+23 NEW DA,IENS
+24 SET DA(1)=BQPIEN
SET DA=BQDL
SET IENS=$$IENS^DILF(.DA)
+25 SET LOCN=$$GET1^DIQ(9000011.11,IENS,.01,"I")
+26 IF LOCN'=""
SET LOC=LOCN_$CHAR(28)_$$GET1^DIQ(9000011.11,IENS,.01,"E")
+27 SET NN=0
+28 FOR
SET NN=$ORDER(^AUPNPROB(BQPIEN,11,BQDL,11,NN))
IF 'NN
QUIT
Begin DoDot:2
+29 NEW DA,IENS
+30 SET DA(2)=BQPIEN
SET DA(1)=BQDL
SET DA=NN
SET IENS=$$IENS^DILF(.DA)
+31 SET PBNIEN=NN
+32 SET PBNTNB=$$GET1^DIQ(9000011.1111,IENS,.01,"E")
+33 SET PBNNAR=$PIECE(^AUPNPROB(BQPIEN,11,BQDL,11,NN,0),U,3)
+34 ;S PBNNAR=$$STRIP^XLFSTR(PBNNAR,$C(13))
+35 ;S PBNNAR=$TR(PBNNAR,$C(10)," ")
+36 SET PBNSTN=$$GET1^DIQ(9000011.1111,IENS,.04,"I")
+37 IF PBNSTN'=""
SET PBNSTAT=PBNSTN_$CHAR(28)_$$GET1^DIQ(9000011.1111,IENS,.04,"E")
+38 SET PBNDT=$$GET1^DIQ(9000011.1111,IENS,.05,"I")
+39 SET PBNUSN=$$GET1^DIQ(9000011.1111,IENS,.06,"I")
+40 IF PBNUSN'=""
SET PBNUSR=PBNUSN_$CHAR(28)_$$GET1^DIQ(9000011.1111,IENS,.06,"E")
+41 SET II=II+1
SET @DATA@(II)=PBNIEN_U_$GET(LOC)_U_$GET(PBNTNB)_U_$GET(PBNNAR)_U_$GET(PBNSTAT)_U_$$FMTE^BQIUL1(PBNDT)_U_$GET(PBNUSR)_$CHAR(30)
End DoDot:2
End DoDot:1
+42 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+43 QUIT
+44 ;
UPD(DATA,PBLIEN,PBNIEN,PARMS) ; EP - BQI UPDATE PROBLEM NOTE
+1 NEW UID,II,VFIEN,FILE,LIST,BN,PDATA,NAME,VALUE,PFIEN,PTYP,CHIEN,FIELD,BQIUPD,FACN
+2 NEW PBNTNB,RESULT,ERROR,BQ,APCDFAC
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 SET DATA=$NAME(^TMP("BQIRPLNU",UID))
+5 KILL @DATA
+6 ;
+7 SET II=0
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER"
+9 SET @DATA@(II)="I00010RESULT^T01024MSG"_$CHAR(30)
+10 SET VFIEN=$ORDER(^BQI(90506.3,"B","Problem Notes",""))
+11 IF VFIEN=""
SET BMXSEC="RPC Call Failed: Problem Notes Definition does not exist."
QUIT
+12 SET FILE=$PIECE(^BQI(90506.3,VFIEN,0),U,2)
+13 ;
+14 SET PARMS=$GET(PARMS,"")
+15 IF PARMS=""
Begin DoDot:1
+16 SET LIST=""
SET BN=""
+17 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+18 KILL PARMS
+19 SET PARMS=LIST
+20 KILL LIST
End DoDot:1
+21 ;
+22 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+23 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+24 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
IF VALUE=""
QUIT
+25 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
+26 SET PTYP=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
+27 IF PTYP="D"!(PTYP="A")
SET VALUE=$$DATE^BQIUL1(VALUE)
+28 ;I PTYP="T" S VALUE=VALUE
+29 IF PTYP="C"
Begin DoDot:2
+30 SET CHIEN=$ORDER(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,""))
IF CHIEN=""
QUIT
+31 SET VALUE=$PIECE(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
End DoDot:2
+32 SET FIELD=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
+33 IF FIELD'=""
SET BQIUPD(FILE,1_",",FIELD)=VALUE
+34 SET @NAME=VALUE
End DoDot:1
+35 ;
+36 SET FACN=""
+37 IF $GET(APCDFAC)=""
SET FACN=$ORDER(^AUPNPROB(PBLIEN,11,"B",DUZ(2),""))
+38 IF $GET(APCDFAC)'=""
SET FACN=$ORDER(^AUPNPROB(PBLIEN,11,"B",APCDFAC,""))
+39 IF FACN=""
Begin DoDot:1
+40 NEW DA,DIC,DLAYGO,Y,X
+41 SET DA(1)=PBLIEN
+42 SET DIC(0)="LN"
SET DLAYGO=9000011.11
SET DIC("P")=DLAYGO
SET DIC="^AUPNPROB("_DA(1)_",11,"
SET X=DUZ(2)
+43 KILL DO,DD
DO FILE^DICN
+44 SET FACN=+Y
End DoDot:1
+45 ;
+46 IF $GET(PBNIEN)=""
Begin DoDot:1
+47 NEW DA,DIC,DLAYGO,Y,X
+48 SET DA(2)=PBLIEN
SET DA(1)=FACN
+49 SET DIC(0)="LN"
SET DLAYGO=9000011.1111
SET DIC("P")=DLAYGO
SET DIC="^AUPNPROB("_DA(2)_",11,"_DA(1)_",11,"
+50 SET X=PBNTNB
+51 KILL DO,DD
DO FILE^DICN
+52 SET PBNIEN=+Y
End DoDot:1
+53 ;
+54 NEW DA,IENS,BQIUPDT
+55 SET DA(2)=PBLIEN
SET DA(1)=FACN
SET DA=PBNIEN
SET IENS=$$IENS^DILF(.DA)
+56 MERGE BQIUPDT(FILE,IENS)=BQIUPD(FILE,1_",")
+57 KILL BQIUPD
+58 DO FILE^DIE("","BQIUPDT","ERROR")
+59 SET RESULT=1_U
+60 IF $DATA(ERROR)>0
SET RESULT=-1_U_$GET(ERROR("DIERR","1","TEXT","1"))
+61 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+62 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+63 QUIT
+64 ;
PLR(DATA,DFN,PARMS) ;EP - BQI UPDATE PRB LIST REV
+1 ;
+2 NEW UID,II,APCDTCDT,APCDTEPR,LIST,BN,VFIEN
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 SET DATA=$NAME(^TMP("BQIRPLN",UID))
+5 KILL @DATA
+6 ;
+7 SET II=0
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER"
+9 SET @DATA@(II)="I00010RESULT^T01024MSG"_$CHAR(30)
+10 ;
+11 SET PARMS=$GET(PARMS,"")
+12 IF PARMS=""
Begin DoDot:1
+13 SET LIST=""
SET BN=""
+14 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+15 KILL PARMS
+16 SET PARMS=LIST
+17 KILL LIST
End DoDot:1
+18 ;
+19 SET VFIEN=$ORDER(^BQI(90506.3,"B","Prob List Reviewed",""))
IF VFIEN=""
SET BMXSEC="Error locating Prob List Reviewed"
GOTO XPLR
+20 ;
+21 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+22 NEW PDATA,NAME,VALUE,PFIEN,PTYP
+23 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+24 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
IF VALUE=""
QUIT
+25 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
+26 SET PTYP=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
+27 SET @NAME=VALUE
End DoDot:1
+28 ;
+29 ;Log V UPDATED/REVIEWED (Updated) entry
+30 DO VUP^BQIRPL("PROBLEM LIST REVIEWED")
+31 SET II=II+1
SET @DATA@(II)=$PIECE($GET(^TMP("BQIVFADD",$JOB,1)),U)_U_$CHAR(30)
+32 KILL ^TMP("BQIVFADD",$JOB)
+33 ;
XPLR SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
NAP(DATA,DFN,PARMS) ;EP - BQI UPDATE NO ACTIVE PRB
+1 ;
+2 NEW UID,II,APCDTCDT,APCDTEPR,LIST,BN,VFIEN
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 SET DATA=$NAME(^TMP("BQIRPLN",UID))
+5 KILL @DATA
+6 ;
+7 SET II=0
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER"
+9 SET @DATA@(II)="I00010RESULT^T01024MSG"_$CHAR(30)
+10 ;
+11 SET PARMS=$GET(PARMS,"")
+12 IF PARMS=""
Begin DoDot:1
+13 SET LIST=""
SET BN=""
+14 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+15 KILL PARMS
+16 SET PARMS=LIST
+17 KILL LIST
End DoDot:1
+18 ;
+19 SET VFIEN=$ORDER(^BQI(90506.3,"B","No Active Problems",""))
IF VFIEN=""
SET BMXSEC="Error locating No Active Problems"
GOTO XNAP
+20 ;
+21 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+22 NEW PDATA,NAME,VALUE,PFIEN,PTYP
+23 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+24 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
IF VALUE=""
QUIT
+25 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
+26 SET PTYP=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
+27 SET @NAME=VALUE
End DoDot:1
+28 ;
+29 ;Log V UPDATED/REVIEWED (Updated) entry
+30 DO VUP^BQIRPL("NO ACTIVE PROBLEMS")
+31 SET II=II+1
SET @DATA@(II)=$PIECE($GET(^TMP("BQIVFADD",$JOB,1)),U)_U_$CHAR(30)
+32 KILL ^TMP("BQIVFADD",$JOB)
+33 ;
XNAP SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
DPLR(DATA,DFN) ;EP - BQI DISPLAY PRB LIST REV
+1 ;
+2 NEW UID,II,APCDTCDT,APCDTEPR
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 SET DATA=$NAME(^TMP("BQIRPLN",UID))
+5 KILL @DATA
+6 ;
+7 SET II=0
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER"
+9 SET @DATA@(II)="I00010DFN^D00030APCDTCDT^T00035APCDTEPR"_$CHAR(30)
+10 ;
+11 SET APCDTCDT=$$LASTPLR^APCLAPI6(DFN,,DT,"A")
+12 SET APCDTEPR=$PIECE(APCDTCDT,U,3)_$CHAR(28)_$$GET1^DIQ(200,$PIECE(APCDTCDT,U,3)_",",.01,"E")
SET APCDTCDT=$$FMTE^BQIUL1($PIECE(APCDTCDT,U))
+13 ;
+14 SET II=II+1
SET @DATA@(II)=DFN_U_APCDTCDT_U_APCDTEPR_$CHAR(30)
+15 ;
XDPLR SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
DNAP(DATA,DFN) ;EP - BQI DISPLAY NO ACTIVE PRB
+1 ;
+2 NEW UID,II,APCDTCDT,APCDTEPR
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 SET DATA=$NAME(^TMP("BQIRPLN",UID))
+5 KILL @DATA
+6 ;
+7 SET II=0
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER"
+9 SET @DATA@(II)="I00010DFN^D00030APCDTCDT^T00035APCDTEPR"_$CHAR(30)
+10 ;
+11 SET APCDTCDT=$$LASTPLR^APCLAPI6(DFN,,DT,"A")
+12 SET APCDTEPR=$PIECE(APCDTCDT,U,3)_$CHAR(28)_$$GET1^DIQ(200,$PIECE(APCDTCDT,U,3)_",",.01,"E")
SET APCDTCDT=$$FMTE^BQIUL1($PIECE(APCDTCDT,U))
+13 ;
+14 SET II=II+1
SET @DATA@(II)=DFN_U_APCDTCDT_U_APCDTEPR_$CHAR(30)
+15 ;
XDNAP SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
PLACT(DATA,DFN) ;EP - BQI ACTIVE PROBLEM LIST
+1 ;
+2 NEW UID,II,ACTIVE,PRBIEN,RESULT,SDATA
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 SET DATA=$NAME(^TMP("BQIRPLN",UID))
+5 KILL @DATA
+6 ;
+7 SET II=0
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIRPL D UNWIND^%ZTER"
+9 SET @DATA@(II)="I00001ACTIVE"_$CHAR(30)
+10 ;
+11 SET RESULT=0
SET SDATA=$PIECE($GET(^DD(9000011,.12,0)),U,3)
+12 SET PRBIEN=""
FOR
SET PRBIEN=$ORDER(^AUPNPROB("AC",DFN,PRBIEN))
IF PRBIEN=""
QUIT
Begin DoDot:1
+13 ;
+14 ;Pull the status of the problem
+15 SET ACTIVE=$$GET1^DIQ(9000011,PRBIEN_",",.12,"I")
+16 IF SDATA["ACTIVE"
IF ACTIVE="A"
SET RESULT=1
QUIT
+17 IF SDATA["CHRONIC"
Begin DoDot:2
+18 SET RESULT=1
+19 IF ACTIVE="D"!(ACTIVE="I")
SET RESULT=0
QUIT
End DoDot:2
End DoDot:1
IF RESULT
QUIT
+20 ;
+21 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+22 ;
XPLACT SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
