BTPWPTBL ;VNGT/HS/ALA-CMET Event Table ; 05 Feb 2009 10:24 AM
;;1.0;CARE MANAGEMENT EVENT TRACKING;;Feb 07, 2011
;
;
LST(DATA,PROC) ; EP -- BTPW GET CMET PROCEDURES
NEW UID,II,TIEN,TTXT,TAXV,X
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BTPWPTBL",UID))
K @DATA
;
S PROC=$G(PROC,"")
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BTPWPTBL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S HDR="I00010PRCIEN^T00030PRCNAME^T00030PRCCAT^T00003PRCACTV^T00003PRCAUTO^T00004PRCRESD^T00004PRCNOTD^T00004PRCFOLD^"
S HDR=HDR_"T00006PRCLIM^T00012PRCGEN^T00010PRCLOW^T00010PRCHIGH^T01024PRCTAX"
S @DATA@(II)=HDR_$C(30)
;
I PROC'="" D PRCS(PROC)
;
I PROC="" D
. S PROC=0
. F S PROC=$O(^BTPW(90621,PROC)) Q:'PROC D PRCS(PROC)
;
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
;
PRCS(PRCN) ;
NEW TDATA,TDATA5,NAME,AUTO,INACT,NOR,NOF,NON,LIM,AGEL,AGEU,GEN,TAX
S TDATA=^BTPW(90621,PRCN,0),TDATA5=$G(^BTPW(90621,PRCN,5))
S CAT=$$CAT^BTPWPDSP(PRCN)
S NAME=$P(TDATA,U,1)
S AUTO=$P(TDATA,U,6),AUTO=$S(AUTO=1:"YES",1:"NO")
S INACT=$P(TDATA,U,3),INACT=$S(INACT'="":"NO",1:"YES")
S NOR=$P(TDATA,U,7),NOF=$P(TDATA,U,8),NON=$P(TDATA,U,9)
S LIM=$P(TDATA5,U,4),AGEL=$P(TDATA5,U,2),AGEU=$P(TDATA5,U,3)
S GEN=$$GET1^DIQ(90621,PRCN_",",5.01,"E")
S TAX="",TXN=0
F S TXN=$O(^BTPW(90621,PRCN,1,TXN)) Q:'TXN D
. S TAX=TAX_$P(^BTPW(90621,PRCN,1,TXN,0),U,1)_$C(28)
S TAX=$$TKO^BQIUL1(TAX,$C(28))
S II=II+1
S @DATA@(II)=PRCN_U_NAME_U_CAT_U_INACT_U_AUTO_U_NOR_U_NON_U_NOF_U_LIM_U_GEN_U_AGEL_U_AGEU_U_TAX_$C(30)
Q
;
FOL(DATA,PRCN) ;EP - Get Followup values
NEW FN,VALUE,RES
S FN=0,VALUE=PRCN_U_$$GET1^DIQ(90621,PRCN_",",.01,"E")
F S FN=$O(^BTPW(90621,PRCN,3,FN)) Q:'FN D
. NEW DA,IENS
. S DA(1)=PRCN,DA=FN,IENS=$$IENS^DILF(.DA)
. S RES=$$GET1^DIQ(90621.03,IENS,.01,"I")_$C(28)_$$GET1^DIQ(90621.03,IENS,.01,"E")
. S WHEN=$$GET1^DIQ(90621.03,IENS,.04,"I"),WHEN=$$FMTE^BQIUL1(WHEN)
. S II=II+1,@DATA@(II)=VALUE_U_RES_U_$$GET1^DIQ(90621.03,IENS,.02,"E")_U_$$GET1^DIQ(90621.03,IENS,.03,"E")_U_WHEN_$C(30)
Q
;
UPD(DATA,PRCN,PARMS) ; EP -- BTPW UPDATE FOLLOWUP PARAMETERS
NEW UID,II,BN,LIST,PDATA,NAME,VALUE,VFIEN,FILE,PTYP,CHIEN,FIELD,EXEC
NEW BTPWDTA,ERROR,RESULT,BQ
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BTPWUPD",UID))
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BTPWPTBL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="I00010RESULT^T001024ERROR"_$C(30)
;
S VFIEN=$O(^BQI(90506.3,"B","CMET Event Followups",""))
I VFIEN="" S BMXSEC="RPC Call Failed: CMET Event Followups 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 Q:$G(BMXSEC)'=""
. S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
. I VALUE="" S VALUE="@"
. S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
. I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
. S PTYP=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
. I PTYP="D" S VALUE=$$DATE^BQIUL1(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)
. S EXEC=$G(^BQI(90506.3,VFIEN,10,PFIEN,7))
. I EXEC'="" X EXEC Q
. I FIELD="" Q
. S DA(1)=PRCN
. I NAME="BTPWPINT" S DA=$O(^BTPW(90621,PRCN,3,"B",VALUE,"")) I DA="" D
.. NEW DIC,DLAYGO,X
.. S X=VALUE,DLAYGO=90621.03,DA(1)=PRCN,DIC="^BTPW(90621,"_DA(1)_",3,",DIC(0)="L"
.. I $G(^BTPW(90621,DA(1),3,0))="" S ^BTPW(90621,DA(1),3,0)="^90621.03S^^"
.. K DO,DD D FILE^DICN
.. S DA=+Y
. NEW IENS
. S IENS=$$IENS^DILF(.DA)
. S BTPWDTA(FILE,IENS,FIELD)=VALUE
. S BTPWDTA(FILE,IENS,.03)=DUZ,BTPWDTA(FILE,IENS,.04)=$$NOW^XLFDT()
D FILE^DIE("","BTPWDTA","ERROR")
;
S RESULT=1_U
I $D(ERROR)>0 S RESULT=-1_U
K ERROR
I $D(BQIDATA)>0 D FILE^DIE("","BTPWDTA","ERROR")
I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1))
I $P(RESULT,U,1)'=-1 S RESULT=1_U
S II=II+1,@DATA@(II)=RESULT_$C(30)
;
S II=II+1,@DATA@(II)=$C(31)
Q
BTPWPTBL ;VNGT/HS/ALA-CMET Event Table ; 05 Feb 2009 10:24 AM
+1 ;;1.0;CARE MANAGEMENT EVENT TRACKING;;Feb 07, 2011
+2 ;
+3 ;
LST(DATA,PROC) ; EP -- BTPW GET CMET PROCEDURES
+1 NEW UID,II,TIEN,TTXT,TAXV,X
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BTPWPTBL",UID))
+4 KILL @DATA
+5 ;
+6 SET PROC=$GET(PROC,"")
+7 SET II=0
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BTPWPTBL D UNWIND^%ZTER"
+9 ;
+10 SET HDR="I00010PRCIEN^T00030PRCNAME^T00030PRCCAT^T00003PRCACTV^T00003PRCAUTO^T00004PRCRESD^T00004PRCNOTD^T00004PRCFOLD^"
+11 SET HDR=HDR_"T00006PRCLIM^T00012PRCGEN^T00010PRCLOW^T00010PRCHIGH^T01024PRCTAX"
+12 SET @DATA@(II)=HDR_$CHAR(30)
+13 ;
+14 IF PROC'=""
DO PRCS(PROC)
+15 ;
+16 IF PROC=""
Begin DoDot:1
+17 SET PROC=0
+18 FOR
SET PROC=$ORDER(^BTPW(90621,PROC))
IF 'PROC
QUIT
DO PRCS(PROC)
End DoDot:1
+19 ;
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 ;
PRCS(PRCN) ;
+1 NEW TDATA,TDATA5,NAME,AUTO,INACT,NOR,NOF,NON,LIM,AGEL,AGEU,GEN,TAX
+2 SET TDATA=^BTPW(90621,PRCN,0)
SET TDATA5=$GET(^BTPW(90621,PRCN,5))
+3 SET CAT=$$CAT^BTPWPDSP(PRCN)
+4 SET NAME=$PIECE(TDATA,U,1)
+5 SET AUTO=$PIECE(TDATA,U,6)
SET AUTO=$SELECT(AUTO=1:"YES",1:"NO")
+6 SET INACT=$PIECE(TDATA,U,3)
SET INACT=$SELECT(INACT'="":"NO",1:"YES")
+7 SET NOR=$PIECE(TDATA,U,7)
SET NOF=$PIECE(TDATA,U,8)
SET NON=$PIECE(TDATA,U,9)
+8 SET LIM=$PIECE(TDATA5,U,4)
SET AGEL=$PIECE(TDATA5,U,2)
SET AGEU=$PIECE(TDATA5,U,3)
+9 SET GEN=$$GET1^DIQ(90621,PRCN_",",5.01,"E")
+10 SET TAX=""
SET TXN=0
+11 FOR
SET TXN=$ORDER(^BTPW(90621,PRCN,1,TXN))
IF 'TXN
QUIT
Begin DoDot:1
+12 SET TAX=TAX_$PIECE(^BTPW(90621,PRCN,1,TXN,0),U,1)_$CHAR(28)
End DoDot:1
+13 SET TAX=$$TKO^BQIUL1(TAX,$CHAR(28))
+14 SET II=II+1
+15 SET @DATA@(II)=PRCN_U_NAME_U_CAT_U_INACT_U_AUTO_U_NOR_U_NON_U_NOF_U_LIM_U_GEN_U_AGEL_U_AGEU_U_TAX_$CHAR(30)
+16 QUIT
+17 ;
FOL(DATA,PRCN) ;EP - Get Followup values
+1 NEW FN,VALUE,RES
+2 SET FN=0
SET VALUE=PRCN_U_$$GET1^DIQ(90621,PRCN_",",.01,"E")
+3 FOR
SET FN=$ORDER(^BTPW(90621,PRCN,3,FN))
IF 'FN
QUIT
Begin DoDot:1
+4 NEW DA,IENS
+5 SET DA(1)=PRCN
SET DA=FN
SET IENS=$$IENS^DILF(.DA)
+6 SET RES=$$GET1^DIQ(90621.03,IENS,.01,"I")_$CHAR(28)_$$GET1^DIQ(90621.03,IENS,.01,"E")
+7 SET WHEN=$$GET1^DIQ(90621.03,IENS,.04,"I")
SET WHEN=$$FMTE^BQIUL1(WHEN)
+8 SET II=II+1
SET @DATA@(II)=VALUE_U_RES_U_$$GET1^DIQ(90621.03,IENS,.02,"E")_U_$$GET1^DIQ(90621.03,IENS,.03,"E")_U_WHEN_$CHAR(30)
End DoDot:1
+9 QUIT
+10 ;
UPD(DATA,PRCN,PARMS) ; EP -- BTPW UPDATE FOLLOWUP PARAMETERS
+1 NEW UID,II,BN,LIST,PDATA,NAME,VALUE,VFIEN,FILE,PTYP,CHIEN,FIELD,EXEC
+2 NEW BTPWDTA,ERROR,RESULT,BQ
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 SET DATA=$NAME(^TMP("BTPWUPD",UID))
+5 KILL @DATA
+6 ;
+7 SET II=0
+8 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BTPWPTBL D UNWIND^%ZTER"
+9 SET @DATA@(II)="I00010RESULT^T001024ERROR"_$CHAR(30)
+10 ;
+11 SET VFIEN=$ORDER(^BQI(90506.3,"B","CMET Event Followups",""))
+12 IF VFIEN=""
SET BMXSEC="RPC Call Failed: CMET Event Followups Definition does not exist."
QUIT
+13 SET FILE=$PIECE(^BQI(90506.3,VFIEN,0),U,2)
+14 ;
+15 SET PARMS=$GET(PARMS,"")
+16 IF PARMS=""
Begin DoDot:1
+17 SET LIST=""
SET BN=""
+18 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+19 KILL PARMS
+20 SET PARMS=LIST
+21 KILL LIST
End DoDot:1
+22 ;
+23 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+24 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+25 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+26 IF VALUE=""
SET VALUE="@"
+27 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
+28 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+29 SET PTYP=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
+30 IF PTYP="D"
SET VALUE=$$DATE^BQIUL1(VALUE)
+31 IF PTYP="C"
Begin DoDot:2
+32 SET CHIEN=$ORDER(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,""))
IF CHIEN=""
QUIT
+33 SET VALUE=$PIECE(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
End DoDot:2
+34 SET FIELD=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
+35 SET EXEC=$GET(^BQI(90506.3,VFIEN,10,PFIEN,7))
+36 IF EXEC'=""
XECUTE EXEC
QUIT
+37 IF FIELD=""
QUIT
+38 SET DA(1)=PRCN
+39 IF NAME="BTPWPINT"
SET DA=$ORDER(^BTPW(90621,PRCN,3,"B",VALUE,""))
IF DA=""
Begin DoDot:2
+40 NEW DIC,DLAYGO,X
+41 SET X=VALUE
SET DLAYGO=90621.03
SET DA(1)=PRCN
SET DIC="^BTPW(90621,"_DA(1)_",3,"
SET DIC(0)="L"
+42 IF $GET(^BTPW(90621,DA(1),3,0))=""
SET ^BTPW(90621,DA(1),3,0)="^90621.03S^^"
+43 KILL DO,DD
DO FILE^DICN
+44 SET DA=+Y
End DoDot:2
+45 NEW IENS
+46 SET IENS=$$IENS^DILF(.DA)
+47 SET BTPWDTA(FILE,IENS,FIELD)=VALUE
+48 SET BTPWDTA(FILE,IENS,.03)=DUZ
SET BTPWDTA(FILE,IENS,.04)=$$NOW^XLFDT()
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+49 DO FILE^DIE("","BTPWDTA","ERROR")
+50 ;
+51 SET RESULT=1_U
+52 IF $DATA(ERROR)>0
SET RESULT=-1_U
+53 KILL ERROR
+54 IF $DATA(BQIDATA)>0
DO FILE^DIE("","BTPWDTA","ERROR")
+55 IF $DATA(ERROR)>0
SET RESULT=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))
+56 IF $PIECE(RESULT,U,1)'=-1
SET RESULT=1_U
+57 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+58 ;
+59 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+60 QUIT
