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)
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(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
;
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
Q
;
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
Q
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
