BQIVFTRB ;PRXM/HC/ALA-Trigger Problem Information ; 18 Dec 2007 3:21 PM
;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
Q
;
EN(DATA,FLAG,TEXT,DXN) ;EP - BQI VFILE TRIGGER PRB
;
; Input
; TEXT - Narrative Text
;
NEW UID,II,VALUE,NARR,SOURCE,CLEAR
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIVFTRB",UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIVFTRB D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S TEXT=$G(TEXT,""),DXN=$G(DXN,"")
D HDR
I FLAG="D",DXN'="" D CLS
I FLAG="N",TEXT'="" D NAR
;
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
;
NAR ;EP - Narrative Text
NEW SOURCE,VALUE,DIC,DLAYGO,X,Y,IEN
S SOURCE="APCDN",VALUE=""
S DIC(0)="LX",DIC="^AUTNPOV(",DLAYGO=9999999.27,X=TEXT
D ^DIC
S IEN=+Y
I IEN=-1 K DO,DD D FILE^DICN S IEN=+Y
S VALUE=IEN_$C(29)_TEXT
S II=II+1,@DATA@(II)=SOURCE_U_"C"_U_VALUE_U_U_U_U_$C(30)
Q
;
CLS ;EP - Problem Classification
NEW SOURCE,VALUE,HELP,CLS,NUM
S SOURCE="APCDCLAS",VALUE="",HELP=""
I $$VERSION^XPDUTL("BJPC")<2.0 D Q
. S II=II+1,@DATA@(II)=SOURCE_U_"C"_U_VALUE_U_U_"N"_U_HELP_U_$G(CLEAR)_$C(30)
; If diagnosis does not trigger a classification
I '$$ASKCL^AUPNVPLC(DXN) D Q
. S CLEAR=SOURCE
. S II=II+1,@DATA@(II)=SOURCE_U_"C"_U_VALUE_U_U_"N"_U_HELP_U_$G(CLEAR)_$C(30)
;
S CLS=$O(^APCDPLCL("B","ASTHMA SEVERITY","")) I CLS="" D Q
. S II=II+1,@DATA@(II)=SOURCE_U_"C"_U_VALUE_U_U_"N"_U_HELP_U_$G(CLEAR)_$C(30)
;
S N=0
F S N=$O(^APCDPLCL(CLS,11,N)) Q:'N D
. S NUM=$P(^APCDPLCL(CLS,11,N,0),U,1)
. S VALUE=VALUE_NUM_$C(29)_NUM_"-"_$P(^APCDPLCL(CLS,11,N,0),U,2)_$C(28)
S VALUE=$$TKO^BQIUL1(VALUE,$C(29))
;
S N=0
F S N=$O(^APCDPLCL(CLS,12,N)) Q:'N D
. S HELP=HELP_^APCDPLCL(CLS,12,N,0)_$C(10)
S HELP=$$TKO^BQIUL1(HELP,$C(10))
S II=II+1,@DATA@(II)=SOURCE_U_"C"_U_VALUE_U_U_"Y"_U_HELP_U_$G(CLEAR)_$C(30)
Q
;
INIT(DATA,BQPIEN) ; EP - BQI VFILE INITIAL PRB
NEW UID,II,VALUE,SOURCE,HELP,DXN,ABLE
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIVFIPR",UID))
K @DATA
S BQPIEN=$G(BQPIEN,"")
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIVFTRB D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="T00008SOURCE^T00001CODE_TYPE^T01024PARMS^T00030PROP_VALUE^T00001ABLE_FLAG^T00200HELP_TEXT"_$C(30)
S SOURCE="APCDCLAS",VALUE="",HELP="",ABLE="N"
I BQPIEN'="",$$VERSION^XPDUTL("BJPC")'<2.0 D
. S DXN=$$GET1^DIQ(9000011,BQPIEN,.01,"I")
. I DXN'="",$$ASKCL^AUPNVPLC(DXN) S ABLE="Y"
S II=II+1,@DATA@(II)=SOURCE_U_"C"_U_VALUE_U_U_ABLE_U_HELP_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
HDR ; Header for BQI VFILE TRIGGER PRB
S @DATA@(II)="T00008SOURCE^T00001CODE_TYPE^T01024PARMS^T00030PROP_VALUE^T00001ABLE_FLAG^T00200HELP_TEXT^T01024CLEAR_FIELDS"_$C(30)
Q
BQIVFTRB ;PRXM/HC/ALA-Trigger Problem Information ; 18 Dec 2007 3:21 PM
+1 ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
+2 QUIT
+3 ;
EN(DATA,FLAG,TEXT,DXN) ;EP - BQI VFILE TRIGGER PRB
+1 ;
+2 ; Input
+3 ; TEXT - Narrative Text
+4 ;
+5 NEW UID,II,VALUE,NARR,SOURCE,CLEAR
+6 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+7 SET DATA=$NAME(^TMP("BQIVFTRB",UID))
+8 KILL @DATA
+9 SET II=0
+10 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIVFTRB D UNWIND^%ZTER"
+11 SET TEXT=$GET(TEXT,"")
SET DXN=$GET(DXN,"")
+12 DO HDR
+13 IF FLAG="D"
IF DXN'=""
DO CLS
+14 IF FLAG="N"
IF TEXT'=""
DO NAR
+15 ;
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 ;
NAR ;EP - Narrative Text
+1 NEW SOURCE,VALUE,DIC,DLAYGO,X,Y,IEN
+2 SET SOURCE="APCDN"
SET VALUE=""
+3 SET DIC(0)="LX"
SET DIC="^AUTNPOV("
SET DLAYGO=9999999.27
SET X=TEXT
+4 DO ^DIC
+5 SET IEN=+Y
+6 IF IEN=-1
KILL DO,DD
DO FILE^DICN
SET IEN=+Y
+7 SET VALUE=IEN_$CHAR(29)_TEXT
+8 SET II=II+1
SET @DATA@(II)=SOURCE_U_"C"_U_VALUE_U_U_U_U_$CHAR(30)
+9 QUIT
+10 ;
CLS ;EP - Problem Classification
+1 NEW SOURCE,VALUE,HELP,CLS,NUM
+2 SET SOURCE="APCDCLAS"
SET VALUE=""
SET HELP=""
+3 IF $$VERSION^XPDUTL("BJPC")<2.0
Begin DoDot:1
+4 SET II=II+1
SET @DATA@(II)=SOURCE_U_"C"_U_VALUE_U_U_"N"_U_HELP_U_$GET(CLEAR)_$CHAR(30)
End DoDot:1
QUIT
+5 ; If diagnosis does not trigger a classification
+6 IF '$$ASKCL^AUPNVPLC(DXN)
Begin DoDot:1
+7 SET CLEAR=SOURCE
+8 SET II=II+1
SET @DATA@(II)=SOURCE_U_"C"_U_VALUE_U_U_"N"_U_HELP_U_$GET(CLEAR)_$CHAR(30)
End DoDot:1
QUIT
+9 ;
+10 SET CLS=$ORDER(^APCDPLCL("B","ASTHMA SEVERITY",""))
IF CLS=""
Begin DoDot:1
+11 SET II=II+1
SET @DATA@(II)=SOURCE_U_"C"_U_VALUE_U_U_"N"_U_HELP_U_$GET(CLEAR)_$CHAR(30)
End DoDot:1
QUIT
+12 ;
+13 SET N=0
+14 FOR
SET N=$ORDER(^APCDPLCL(CLS,11,N))
IF 'N
QUIT
Begin DoDot:1
+15 SET NUM=$PIECE(^APCDPLCL(CLS,11,N,0),U,1)
+16 SET VALUE=VALUE_NUM_$CHAR(29)_NUM_"-"_$PIECE(^APCDPLCL(CLS,11,N,0),U,2)_$CHAR(28)
End DoDot:1
+17 SET VALUE=$$TKO^BQIUL1(VALUE,$CHAR(29))
+18 ;
+19 SET N=0
+20 FOR
SET N=$ORDER(^APCDPLCL(CLS,12,N))
IF 'N
QUIT
Begin DoDot:1
+21 SET HELP=HELP_^APCDPLCL(CLS,12,N,0)_$CHAR(10)
End DoDot:1
+22 SET HELP=$$TKO^BQIUL1(HELP,$CHAR(10))
+23 SET II=II+1
SET @DATA@(II)=SOURCE_U_"C"_U_VALUE_U_U_"Y"_U_HELP_U_$GET(CLEAR)_$CHAR(30)
+24 QUIT
+25 ;
INIT(DATA,BQPIEN) ; EP - BQI VFILE INITIAL PRB
+1 NEW UID,II,VALUE,SOURCE,HELP,DXN,ABLE
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BQIVFIPR",UID))
+4 KILL @DATA
+5 SET BQPIEN=$GET(BQPIEN,"")
+6 SET II=0
+7 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIVFTRB D UNWIND^%ZTER"
+8 SET @DATA@(II)="T00008SOURCE^T00001CODE_TYPE^T01024PARMS^T00030PROP_VALUE^T00001ABLE_FLAG^T00200HELP_TEXT"_$CHAR(30)
+9 SET SOURCE="APCDCLAS"
SET VALUE=""
SET HELP=""
SET ABLE="N"
+10 IF BQPIEN'=""
IF $$VERSION^XPDUTL("BJPC")'<2.0
Begin DoDot:1
+11 SET DXN=$$GET1^DIQ(9000011,BQPIEN,.01,"I")
+12 IF DXN'=""
IF $$ASKCL^AUPNVPLC(DXN)
SET ABLE="Y"
End DoDot:1
+13 SET II=II+1
SET @DATA@(II)=SOURCE_U_"C"_U_VALUE_U_U_ABLE_U_HELP_$CHAR(30)
+14 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+15 QUIT
+16 ;
HDR ; Header for BQI VFILE TRIGGER PRB
+1 SET @DATA@(II)="T00008SOURCE^T00001CODE_TYPE^T01024PARMS^T00030PROP_VALUE^T00001ABLE_FLAG^T00200HELP_TEXT^T01024CLEAR_FIELDS"_$CHAR(30)
+2 QUIT
