Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BTPWPTBL

BTPWPTBL.m

Go to the documentation of this file. 
  1. BTPWPTBL ;VNGT/HS/ALA-CMET Event Table ; 05 Feb 2009  10:24 AM
  1.  ;;1.0;CARE MANAGEMENT EVENT TRACKING;;Feb 07, 2011
  1.  ;
  1.  ;
  1. LST(DATA,PROC) ; EP -- BTPW GET CMET PROCEDURES
  1.  NEW UID,II,TIEN,TTXT,TAXV,X
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BTPWPTBL",UID))
  1.  K @DATA
  1.  ;
  1.  S PROC=$G(PROC,"")
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BTPWPTBL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  ;
  1.  S HDR="I00010PRCIEN^T00030PRCNAME^T00030PRCCAT^T00003PRCACTV^T00003PRCAUTO^T00004PRCRESD^T00004PRCNOTD^T00004PRCFOLD^"
  1.  S HDR=HDR_"T00006PRCLIM^T00012PRCGEN^T00010PRCLOW^T00010PRCHIGH^T01024PRCTAX"
  1.  S @DATA@(II)=HDR_$C(30)
  1.  ;
  1.  I PROC'="" D PRCS(PROC)
  1.  ;
  1.  I PROC="" D
  1.  . S PROC=0
  1.  . F  S PROC=$O(^BTPW(90621,PROC)) Q:'PROC  D PRCS(PROC)
  1.  ;
  1. DONE ;
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. ERR ;
  1.  D ^%ZTER
  1.  NEW Y,ERRDTM
  1.  S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
  1.  S BMXSEC="Recording that an error occurred at "_ERRDTM
  1.  I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
  1.  Q
  1.  ;
  1. PRCS(PRCN) ;
  1.  NEW TDATA,TDATA5,NAME,AUTO,INACT,NOR,NOF,NON,LIM,AGEL,AGEU,GEN,TAX
  1.  S TDATA=^BTPW(90621,PRCN,0),TDATA5=$G(^BTPW(90621,PRCN,5))
  1.  S CAT=$$CAT^BTPWPDSP(PRCN)
  1.  S NAME=$P(TDATA,U,1)
  1.  S AUTO=$P(TDATA,U,6),AUTO=$S(AUTO=1:"YES",1:"NO")
  1.  S INACT=$P(TDATA,U,3),INACT=$S(INACT'="":"NO",1:"YES")
  1.  S NOR=$P(TDATA,U,7),NOF=$P(TDATA,U,8),NON=$P(TDATA,U,9)
  1.  S LIM=$P(TDATA5,U,4),AGEL=$P(TDATA5,U,2),AGEU=$P(TDATA5,U,3)
  1.  S GEN=$$GET1^DIQ(90621,PRCN_",",5.01,"E")
  1.  S TAX="",TXN=0
  1.  F  S TXN=$O(^BTPW(90621,PRCN,1,TXN)) Q:'TXN  D
  1.  . S TAX=TAX_$P(^BTPW(90621,PRCN,1,TXN,0),U,1)_$C(28)
  1.  S TAX=$$TKO^BQIUL1(TAX,$C(28))
  1.  S II=II+1
  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)
  1.  Q
  1.  ;
  1. FOL(DATA,PRCN) ;EP - Get Followup values
  1.  NEW FN,VALUE,RES
  1.  S FN=0,VALUE=PRCN_U_$$GET1^DIQ(90621,PRCN_",",.01,"E")
  1.  F  S FN=$O(^BTPW(90621,PRCN,3,FN)) Q:'FN  D
  1.  . NEW DA,IENS
  1.  . S DA(1)=PRCN,DA=FN,IENS=$$IENS^DILF(.DA)
  1.  . S RES=$$GET1^DIQ(90621.03,IENS,.01,"I")_$C(28)_$$GET1^DIQ(90621.03,IENS,.01,"E")
  1.  . S WHEN=$$GET1^DIQ(90621.03,IENS,.04,"I"),WHEN=$$FMTE^BQIUL1(WHEN)
  1.  . 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)
  1.  Q
  1.  ;
  1. UPD(DATA,PRCN,PARMS) ; EP -- BTPW UPDATE FOLLOWUP PARAMETERS
  1.  NEW UID,II,BN,LIST,PDATA,NAME,VALUE,VFIEN,FILE,PTYP,CHIEN,FIELD,EXEC
  1.  NEW BTPWDTA,ERROR,RESULT,BQ
  1.  S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
  1.  S DATA=$NA(^TMP("BTPWUPD",UID))
  1.  K @DATA
  1.  ;
  1.  S II=0
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BTPWPTBL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
  1.  S @DATA@(II)="I00010RESULT^T001024ERROR"_$C(30)
  1.  ;
  1.  S VFIEN=$O(^BQI(90506.3,"B","CMET Event Followups",""))
  1.  I VFIEN="" S BMXSEC="RPC Call Failed: CMET Event Followups Definition does not exist." Q
  1.  S FILE=$P(^BQI(90506.3,VFIEN,0),U,2)
  1.  ;
  1.  S PARMS=$G(PARMS,"")
  1.  I PARMS="" D
  1.  . S LIST="",BN=""
  1.  . F  S BN=$O(PARMS(BN)) Q:BN=""  S LIST=LIST_PARMS(BN)
  1.  . K PARMS
  1.  . S PARMS=LIST
  1.  . K LIST
  1.  ;
  1.  F BQ=1:1:$L(PARMS,$C(28)) D  Q:$G(BMXSEC)'=""
  1.  . S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
  1.  . S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
  1.  . I VALUE="" S VALUE="@"
  1.  . S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
  1.  . I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
  1.  . S PTYP=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
  1.  . I PTYP="D" S VALUE=$$DATE^BQIUL1(VALUE)
  1.  . I PTYP="C" D
  1.  .. S CHIEN=$O(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,"")) I CHIEN="" Q
  1.  .. S VALUE=$P(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
  1.  . S FIELD=$P($G(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
  1.  . S EXEC=$G(^BQI(90506.3,VFIEN,10,PFIEN,7))
  1.  . I EXEC'="" X EXEC Q
  1.  . I FIELD="" Q
  1.  . S DA(1)=PRCN
  1.  . I NAME="BTPWPINT" S DA=$O(^BTPW(90621,PRCN,3,"B",VALUE,"")) I DA="" D
  1.  .. NEW DIC,DLAYGO,X
  1.  .. S X=VALUE,DLAYGO=90621.03,DA(1)=PRCN,DIC="^BTPW(90621,"_DA(1)_",3,",DIC(0)="L"
  1.  .. I $G(^BTPW(90621,DA(1),3,0))="" S ^BTPW(90621,DA(1),3,0)="^90621.03S^^"
  1.  .. K DO,DD D FILE^DICN
  1.  .. S DA=+Y
  1.  . NEW IENS
  1.  . S IENS=$$IENS^DILF(.DA)
  1.  . S BTPWDTA(FILE,IENS,FIELD)=VALUE
  1.  . S BTPWDTA(FILE,IENS,.03)=DUZ,BTPWDTA(FILE,IENS,.04)=$$NOW^XLFDT()
  1.  D FILE^DIE("","BTPWDTA","ERROR")
  1.  ;
  1.  S RESULT=1_U
  1.  I $D(ERROR)>0 S RESULT=-1_U
  1.  K ERROR
  1.  I $D(BQIDATA)>0 D FILE^DIE("","BTPWDTA","ERROR")
  1.  I $D(ERROR)>0 S RESULT=-1_U_$G(ERROR("DIERR",1,"TEXT",1))
  1.  I $P(RESULT,U,1)'=-1 S RESULT=1_U
  1.  S II=II+1,@DATA@(II)=RESULT_$C(30)
  1.  ;
  1.  S II=II+1,@DATA@(II)=$C(31)
  1.  Q