Routine: BQIRGTHM

BQIRGTHM ;PRXM/HC/ALA-Proposed Value Trigger RPC for HMS ; 30 Nov 2007  5:55 PM

 ;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59

EN(DATA,BQDFN,DCAT) ;EP - BQI REGISTER TRIGGER HMS

 ; Input

 ;   BQDFN - Patient internal entry number

 ;   DCAT  - Diagnosis category

 NEW UID,II,PARMS,DA,IENS,NM,VALUE,TEXT,ABLE,PPARMS,BKMIEN,BKMREG,BKMIENS

 NEW BI,BN,HELP,BCPTR,CPT,BDATA,LM

 S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)

 S DATA=$NA(^TMP("BQIRGTHM",UID))

 K @DATA

 S II=0

 NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIRGTHM D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2

 S @DATA@(II)="T00008SOURCE^T00001CODE_TYPE^T01024PARMS^T00200HELP_TEXT^T00030PROP_VALUE^T00001ABLE_FLAG"_$C(30)

 ; Build internal

 S BKMIEN=$$BKMIEN^BKMIXX3(BQDFN)

 S BKMREG=$$BKMREG^BKMIXX3(BKMIEN)

 S DA(1)=BKMIEN,DA=BKMREG

 S BKMIENS=$$IENS^DILF(.DA)

 S PARMS("BKMDCAT")=$$GET1^DIQ(90451.01,BKMIENS,2.3,"E")

 S PARMS("BKMDXDT")=$$FMTE^BQIUL1($$GET1^DIQ(90451.01,BKMIENS,5,"I"))

 S PARMS("BKMAIDT")=$$FMTE^BQIUL1($$GET1^DIQ(90451.01,BKMIENS,5.5,"I"))

 I BKMIENS=",," D FND

 I $G(PARMS("BKMDCAT"))=""!($G(PARMS("BKMDXDT"))="") D FND

 ;S PARMS("BKMDCAT")=$$STC^BQIUL2(90451.01,2.3,$$DIAG^BKMVA1B(BQDFN))

 ;S PARMS("BKMDXDT")=$$FMTE^BQIUL1($$GET1^DIQ(90451.01,BKMIENS,5,"I"))

 ;S PARMS("BKMAIDT")=$$FMTE^BQIUL1($$GET1^DIQ(90451.01,BKMIENS,5.5,"I"))

 ;S PARMS("BKMDCAT")=$$DIAG^BKMVA1B(BQDFN)

 ;S PARMS("BKMDXDT")=$$GET1^DIQ(90451.01,BKMIENS,5,"I")

 ;S PARMS("BKMAIDT")=$$GET1^DIQ(90451.01,BKMIENS,5.5,"I")

 S NM=""

 F  S NM=$O(PARMS(NM)) Q:NM=""  I $G(PARMS(NM))'="" S PPARMS(NM)=""

 I $G(DCAT)="" D

 . F BI=1:1 S LM=$T(LST+BI) Q:LM=" Q"  D

 .. S TEXT=$P(LM,";;",2)

 .. S ABLE(TEXT)="N",PARMS(TEXT)=""

 I $G(DCAT)'="" S PARMS("BKMDCAT")=DCAT,PPARMS("BKMDCAT")=""

 I $G(PARMS("BKMDCAT"))'="" D

 . D EN^BQIRGTH1(.BDATA,PARMS("BKMDCAT"))

 . S BN=0

 . F  S BN=$O(@BDATA@(BN)) Q:BN=""  D

 .. S TEXT=$P(@BDATA@(BN),U,1)

 .. S ABLE(TEXT)=$P(@BDATA@(BN),U,2)

 . K @BDATA

 ;F TXT="BKMDCOM","BKMETIO","BKMCLCLS","BKMPTSTA","BKMLOC" S ABLE(TXT)="Y"

 ; Figure out the fields that are enabled or disabled

 ;I $G(PPARMS("BKMDCAT"))="A"!($G(PARMS("BKMDCAT"))="A") D

 ;. F TXT="BKMAIDT","BKMDXDT","BKMHPROV","BKMHCSMR","BKMSHRST","BKMSARST" S ABLE(TXT)="Y"

 ;I $G(PPARMS("BKMDCAT"))="H"!($G(PARMS("BKMDCAT"))="H") D

 ;. F TXT="BKMHPROV","BKMDXDT","BKMHCSMR","BKMSHRST" S ABLE(TXT)="Y"

 ;. F TXT="BKMAIDT","BKMSARST" S ABLE(TXT)="N"

 S NM="",VALUE="",HELP=""

 F  S NM=$O(PARMS(NM)) Q:NM=""  D

 . S VALUE=NM_U

 . S $P(VALUE,U,3)=$S($G(PARMS(NM))'="":$G(PARMS(NM)),1:"")

 . S $P(VALUE,U,4)=HELP

 . S $P(VALUE,U,5)=$S($G(PARMS(NM))=""&$G(PPARMS(NM))'="":$G(PPARMS(NM)),1:"")

 . S $P(VALUE,U,6)=$S($G(ABLE(NM))'="":$G(ABLE(NM)),1:"Y")

 . S II=II+1,@DATA@(II)=VALUE_$C(30)

DONE ;

 S II=II+1,@DATA@(II)=$C(31)

ERR ;

 D ^%ZTER

 NEW Y,ERRDTM

 S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y

 S BMXSEC="Recording that an error occurred at "_ERRDTM

 I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)

FND ; Find initial data

 K DIAGCAT,IAIDSDT,HAIDSDT

 D LDREC^BKMVA1B(BQDFN,1)

 S PPARMS("BKMAIDT")=$$FMTE^BQIUL1(IAIDSDT)

 S PPARMS("BKMDXDT")=$$FMTE^BQIUL1(HAIDSDT)

 S PPARMS("BKMDCAT")=$$STC^BQIUL2(90451.01,2.3,DIAGCAT)

 K DIAGCAT,IAIDSDT,HAIDSDT

LST ;

 ;;BKMCLCLS

 ;;BKMDCOM

 ;;BKMETIO

 ;;BKMETIOC

 ;;BKMETIOD

 ;;BKMHCCOM

 ;;BKMHCDT

 ;;BKMHCSMR

 ;;BKMHCST

 ;;BKMHCWHN

 ;;BKMHCWHO

 ;;BKMHPROV

 ;;BKMHTACM

 ;;BKMHTADT

 ;;BKMHTAST

 ;;BKMHTAWD

 ;;BKMHTAWH

 ;;BKMHTNAR

 ;;BKMIENS

 ;;BKMLOC

 ;;BKMPTDT

 ;;BKMPTLUP

 ;;BKMPTSTA

 ;;BKMRCOM

 ;;BKMSAADT

 ;;BKMSAAST

 ;;BKMSARDT

 ;;BKMSARST

 ;;BKMSHADT

 ;;BKMSHAST

 ;;BKMSHRDT

 ;;BKMSHRST

 ;;BKMWHOM

BQIRGTHM  ;PRXM/HC/ALA-Proposed Value Trigger RPC for HMS ; 30 Nov 2007  5:55 PM

 +1       ;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59

 +2       ;

EN(DATA,BQDFN,DCAT) ;EP - BQI REGISTER TRIGGER HMS

 +1       ;

 +2       ; Input

 +3       ;   BQDFN - Patient internal entry number

 +4       ;   DCAT  - Diagnosis category

 +5       ;

 +6        NEW UID,II,PARMS,DA,IENS,NM,VALUE,TEXT,ABLE,PPARMS,BKMIEN,BKMREG,BKMIENS

 +7        NEW BI,BN,HELP,BCPTR,CPT,BDATA,LM

 +8        SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)

 +9        SET DATA=$NAME(^TMP("BQIRGTHM",UID))

 +10       KILL @DATA

 +11       SET II=0

 +12      ; SAC 2006 2.2.3.3.2

           NEW $ESTACK,$ETRAP

           SET $ETRAP="D ERR^BQIRGTHM D UNWIND^%ZTER"

 +13      ;

 +14       SET @DATA@(II)="T00008SOURCE^T00001CODE_TYPE^T01024PARMS^T00200HELP_TEXT^T00030PROP_VALUE^T00001ABLE_FLAG"_$CHAR(30)

 +15      ;

 +16      ; Build internal

 +17       SET BKMIEN=$$BKMIEN^BKMIXX3(BQDFN)

 +18       SET BKMREG=$$BKMREG^BKMIXX3(BKMIEN)

 +19       SET DA(1)=BKMIEN

           SET DA=BKMREG

 +20       SET BKMIENS=$$IENS^DILF(.DA)

 +21      ;

 +22       SET PARMS("BKMDCAT")=$$GET1^DIQ(90451.01,BKMIENS,2.3,"E")

 +23       SET PARMS("BKMDXDT")=$$FMTE^BQIUL1($$GET1^DIQ(90451.01,BKMIENS,5,"I"))

 +24       SET PARMS("BKMAIDT")=$$FMTE^BQIUL1($$GET1^DIQ(90451.01,BKMIENS,5.5,"I"))

 +25      ;

 +26       IF BKMIENS=",,"

               DO FND

 +27       IF $GET(PARMS("BKMDCAT"))=""!($GET(PARMS("BKMDXDT"))="")

               DO FND

 +28      ;

 +29      ;S PARMS("BKMDCAT")=$$STC^BQIUL2(90451.01,2.3,$$DIAG^BKMVA1B(BQDFN))

 +30      ;S PARMS("BKMDXDT")=$$FMTE^BQIUL1($$GET1^DIQ(90451.01,BKMIENS,5,"I"))

 +31      ;S PARMS("BKMAIDT")=$$FMTE^BQIUL1($$GET1^DIQ(90451.01,BKMIENS,5.5,"I"))

 +32      ;S PARMS("BKMDCAT")=$$DIAG^BKMVA1B(BQDFN)

 +33      ;S PARMS("BKMDXDT")=$$GET1^DIQ(90451.01,BKMIENS,5,"I")

 +34      ;S PARMS("BKMAIDT")=$$GET1^DIQ(90451.01,BKMIENS,5.5,"I")

 +35      ;

 +36       SET NM=""

 +37       FOR

               SET NM=$ORDER(PARMS(NM))

               IF NM=""

                   QUIT

               IF $GET(PARMS(NM))'=""

                   SET PPARMS(NM)=""

 +38      ;

 +39       IF $GET(DCAT)=""

               Begin DoDot:1

 +40               FOR BI=1:1

                       SET LM=$TEXT(LST+BI)

                       IF LM=" Q"

                           QUIT

                       Begin DoDot:2

 +41                       SET TEXT=$PIECE(LM,";;",2)

 +42                       SET ABLE(TEXT)="N"

                           SET PARMS(TEXT)=""

                       End DoDot:2

               End DoDot:1

 +43      ;

 +44       IF $GET(DCAT)'=""

               SET PARMS("BKMDCAT")=DCAT

               SET PPARMS("BKMDCAT")=""

 +45       IF $GET(PARMS("BKMDCAT"))'=""

               Begin DoDot:1

 +46               DO EN^BQIRGTH1(.BDATA,PARMS("BKMDCAT"))

 +47               SET BN=0

 +48               FOR

                       SET BN=$ORDER(@BDATA@(BN))

                       IF BN=""

                           QUIT

                       Begin DoDot:2

 +49                       SET TEXT=$PIECE(@BDATA@(BN),U,1)

 +50                       SET ABLE(TEXT)=$PIECE(@BDATA@(BN),U,2)

                       End DoDot:2

 +51               KILL @BDATA

               End DoDot:1

 +52      ;F TXT="BKMDCOM","BKMETIO","BKMCLCLS","BKMPTSTA","BKMLOC" S ABLE(TXT)="Y"

 +53      ;

 +54      ; Figure out the fields that are enabled or disabled

 +55      ;I $G(PPARMS("BKMDCAT"))="A"!($G(PARMS("BKMDCAT"))="A") D

 +56      ;. F TXT="BKMAIDT","BKMDXDT","BKMHPROV","BKMHCSMR","BKMSHRST","BKMSARST" S ABLE(TXT)="Y"

 +57      ;I $G(PPARMS("BKMDCAT"))="H"!($G(PARMS("BKMDCAT"))="H") D

 +58      ;. F TXT="BKMHPROV","BKMDXDT","BKMHCSMR","BKMSHRST" S ABLE(TXT)="Y"

 +59      ;. F TXT="BKMAIDT","BKMSARST" S ABLE(TXT)="N"

 +60      ;

 +61       SET NM=""

           SET VALUE=""

           SET HELP=""

 +62       FOR

               SET NM=$ORDER(PARMS(NM))

               IF NM=""

                   QUIT

               Begin DoDot:1

 +63               SET VALUE=NM_U

 +64               SET $PIECE(VALUE,U,3)=$SELECT($GET(PARMS(NM))'="":$GET(PARMS(NM)),1:"")

 +65               SET $PIECE(VALUE,U,4)=HELP

 +66               SET $PIECE(VALUE,U,5)=$SELECT($GET(PARMS(NM))=""&$GET(PPARMS(NM))'="":$GET(PPARMS(NM)),1:"")

 +67               SET $PIECE(VALUE,U,6)=$SELECT($GET(ABLE(NM))'="":$GET(ABLE(NM)),1:"Y")

 +68               SET II=II+1

                   SET @DATA@(II)=VALUE_$CHAR(30)

               End DoDot:1

 +69      ;

DONE      ;

 +1        SET II=II+1

           SET @DATA@(II)=$CHAR(31)

 +2        QUIT

 +3       ;

ERR       ;

 +1        DO ^%ZTER

 +2        NEW Y,ERRDTM

 +3        SET Y=$$NOW^XLFDT()

           XECUTE ^DD("DD")

           SET ERRDTM=Y

 +4        SET BMXSEC="Recording that an error occurred at "_ERRDTM

 +5        IF $DATA(II)

               IF $DATA(DATA)

                   SET II=II+1

                   SET @DATA@(II)=$CHAR(31)

 +6        QUIT

 +7       ;

FND       ; Find initial data

 +1        KILL DIAGCAT,IAIDSDT,HAIDSDT

 +2        DO LDREC^BKMVA1B(BQDFN,1)

 +3        SET PPARMS("BKMAIDT")=$$FMTE^BQIUL1(IAIDSDT)

 +4        SET PPARMS("BKMDXDT")=$$FMTE^BQIUL1(HAIDSDT)

 +5        SET PPARMS("BKMDCAT")=$$STC^BQIUL2(90451.01,2.3,DIAGCAT)

 +6        KILL DIAGCAT,IAIDSDT,HAIDSDT

 +7        QUIT

 +8       ;

LST       ;

 +1       ;;BKMCLCLS

 +2       ;;BKMDCOM

 +3       ;;BKMETIO

 +4       ;;BKMETIOC

 +5       ;;BKMETIOD

 +6       ;;BKMHCCOM

 +7       ;;BKMHCDT

 +8       ;;BKMHCSMR

 +9       ;;BKMHCST

 +10      ;;BKMHCWHN

 +11      ;;BKMHCWHO

 +12      ;;BKMHPROV

 +13      ;;BKMHTACM

 +14      ;;BKMHTADT

 +15      ;;BKMHTAST

 +16      ;;BKMHTAWD

 +17      ;;BKMHTAWH

 +18      ;;BKMHTNAR

 +19      ;;BKMIENS

 +20      ;;BKMLOC

 +21      ;;BKMPTDT

 +22      ;;BKMPTLUP

 +23      ;;BKMPTSTA

 +24      ;;BKMRCOM

 +25      ;;BKMSAADT

 +26      ;;BKMSAAST

 +27      ;;BKMSARDT

 +28      ;;BKMSARST

 +29      ;;BKMSHADT

 +30      ;;BKMSHAST

 +31      ;;BKMSHRDT

 +32      ;;BKMSHRST

 +33      ;;BKMWHOM

 +34       QUIT

BQIRGTHM.m