BQIRPLN.m

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)