BTPWSCHD.m

BTPWSCHD ;VNGT/HS/ALA-CMET Scheduler ; 19 Jun 2009  9:40 AM

 ;;1.0;CARE MANAGEMENT EVENT TRACKING;;Feb 07, 2011

 ;

EN ; Entry point

 NEW DR,DIE,DA,DIC,DLAYGO,BI,FREQ,I,OPT,OPTN,OPTION,SAT,SUN,SDATM,SDOW,TIME,X

 NEW DIFROM,CIEN,CDATM,CDATE,CTIME,DIFF,ERROR,Y,BTPWDA,ECTIME,EFREQ,BTPWDA

 S BTPWDA=1,QFL=0

 S ECTIME=$$GET1^DIQ(90628,BTPWDA_",",.05,"E"),EFREQ=$$GET1^DIQ(90628,BTPWDA_",",.04,"E")

 ;

 F BI=1:1 S OPT=$P($T(TSK+BI)," ;;",2,99) Q:OPT=""  D  Q:'QFL

 . S OPTION=$P(OPT,U,1),FREQ=$P(OPT,U,2)

 . I EFREQ'="",EFREQ'=FREQ S FREQ=EFREQ

 . I '$$GET1^DIQ(90628,BTPWDA_",",.03,"I") Q

 . S QFL=1

 . S OPTN=$$FIND(OPTION) Q:OPTN'>0

 . I $O(^DIC(19.2,"B",OPTN,""))'="" D  Q

 .. S CIEN=$O(^DIC(19.2,"B",OPTN,""))

 .. S CDATM=$P(^DIC(19.2,CIEN,0),U,2)

 .. S CDATE=$P(CDATM,".",1),CTIME=$P(CDATM,".",2)

 .. I ECTIME'="",ECTIME'=CTIME S CTIME=ECTIME

 .. I CDATE>DT Q

 .. S DIFF=$$FMDIFF^XLFDT(DT,CDATE,1)

 .. I DIFF'>14 Q

 .. S SDOW=$P(OPT,U,3) I SDOW'="" D

 ... S SAT=$$SAT^BQISCHED(DT)

 ... S SUN=$$FMADD^XLFDT(SAT,1)

 ... I SDOW="SAT" S SDATM=SAT_"."_CTIME

 ... I SDOW="SUN" S SDATM=SUN_"."_CTIME

 ... D RESCH^XUTMOPT(OPTION,SDATM,"",FREQ,"L",.ERROR)

 . ;

 . S OPTION=$P(OPT,U,1)

 . ;S FREQ=$P(OPT,U,2)

 . S SDOW=$P(OPT,U,3) I SDOW'="" D

 .. S SAT=$$SAT^BQISCHED(DT)

 .. S SUN=$$FMADD^XLFDT(SAT,1)

 . ;S TIME=$P(OPT,U,4),TIME=$$STRIP^BQIUL1(TIME,"0")

 . S TIME=ECTIME,TIME=$$STRIP^BQIUL1(TIME,"0")

 . I SDOW="" S SDATM=$$FMADD^XLFDT(DT,1)_"."_TIME

 . I SDOW="SAT" S SDATM=SAT_"."_TIME

 . I SDOW="SUN" S SDATM=SUN_"."_TIME

 . D RESCH^XUTMOPT(OPTION,SDATM,"",FREQ,"L",.ERROR)

 . K SDOW,SAT,SUN,TIME

 Q

 ;

GET(DATA,FAKE) ;EP -- BTPW GET SITE PARAMETERS

 ; Get specific CMET system parameters from the Site Parameter file

 NEW UID,II,IEN,JOB,FREQ,START,DDATA

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

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

 K @DATA

 ;

 S II=0

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

 ;

 S @DATA@(II)="T00003BTPWSJOB^T00004BTPWQFRQ^T00004BTPWQSTT^T00035WHO^D00030WHEN"_$C(30)

 ;

 S IEN=$O(^BTPW(90628,0)) I IEN="" S BMXSEC="No site defined" Q

 S DDATA=$G(^BTPW(90628,IEN,0))

 S JOB=$P(DDATA,U,3)

 S FREQ=$P(DDATA,U,4)

 S START=$P(DDATA,U,5)

 S WHO=$$GET1^DIQ(90628,IEN_",",.09,"E")

 S WHEN=$$GET1^DIQ(90628,IEN_",",.1,"I"),WHEN=$$FMTE^BQIUL1(WHEN)

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

 ;

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

 Q

 ;

EDUE(DATA,FAKE) ; EP -- BTPW GET EVENT DUE PARAMS

 ; Retrieves the information about the default due dates

 NEW UID,II,IEN,DDATA,ERDUE,ERWHEN,ERWHO,EFDUE,EFWHEN,EFWHO,ENDUE,ENWHEN,ENWHO

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

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

 K @DATA

 ;

 S II=0

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

 ;

 S @DATA@(II)="T00004BTPWERDU^D00030ERWHEN^T00035ERWHO^T00004BTPWEFDU^D00030EFWHEN^"

 S @DATA@(II)=@DATA@(II)_"T00035EFWHO^T00004BTPWENDU^D00030ENWHEN^T00035ENWHO"_$C(30)

 ;

 S IEN=$O(^BTPW(90628,0))

 S DDATA=$G(^BTPW(90628,IEN,1))

 S ERDUE=$P(DDATA,U,1),ERWHEN=$P(DDATA,U,4),ERWHEN=$$FMTE^BQIUL1(ERWHEN)

 S ERWHO=$$GET1^DIQ(90628,IEN_",",1.05,"E")

 S EFDUE=$P(DDATA,U,2),EFWHEN=$P(DDATA,U,6),EFWHEN=$$FMTE^BQIUL1(EFWHEN)

 S EFWHO=$$GET1^DIQ(90628,IEN_",",1.07,"E")

 S ENDUE=$P(DDATA,U,3),ENWHEN=$P(DDATA,U,8),ENWHEN=$$FMTE^BQIUL1(ENWHEN)

 S ENWHO=$$GET1^DIQ(90628,IEN_",",1.09,"E")

 ;

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

 ;

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

 Q

 ;

UDUE(DATA,PARMS) ;EP -- BTPW UPDATE EVENT DUE

 ; Updates the default event due date frequency

 NEW UID,II,BN,LIST,PDATA,NAME,VALUE,VFIEN,FILE,PTYP,CHIEN,FIELD,EXEC

 NEW BQIDATA,ERROR,RESULT

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

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

 K @DATA

 ;

 S II=0

 NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIWSCHD 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 Due",""))

 I VFIEN="" S BMXSEC="RPC Call Failed: CMET Event Due Definition does not exist." Q

 S FILE=$P(^BQI(90506.3,VFIEN,0),U,2),BTPWDA=1

 D GEN

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

 Q

 ; 

FOL(DATA,FAKE) ;EP -- BTPW GET FOLLOWUP PARAMETERS

 ; Returns the values for the special followup defaults

 NEW UID,II,IEN,PRCN,PN,NOT,PDATA,PDATA1,WHO,WHEN,EVT,FIND

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

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

 K @DATA

 ;

 S II=0

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

 ;

 ;S @DATA@(II)="I00010EVIEN^T00030EVNAME^T00030BTPWPINT^T00004BTPWPFRQ^T00030EVWHOM^D00030EVWHEN"_$C(30)

 S @DATA@(II)="I00010EVIEN^T00030EVNAME^T00004BTPWPFRQ^T00030EVWHOM^D00030EVWHEN^T00030EVNOT^T00065BTPNFIND"_$C(30)

 ;

 S IEN=$O(^BTPW(90628,0))

 S PN=0

 F  S PN=$O(^BTPW(90628,IEN,2,PN)) Q:'PN  D

 . S PDATA=^BTPW(90628,IEN,2,PN,0)

 . S PRCN=$P(PDATA,U,1),FREQ=$P(PDATA,U,2),WHO=$P(PDATA,U,3),WHEN=$P(PDATA,U,4),NOT=$P(PDATA,U,5)

 . S PDATA1=$G(^BTPW(90628,IEN,2,PN,1))

 . S FIND=$P(PDATA1,U,1)

 . I WHO'="" S WHO=$P(^VA(200,WHO,0),U,1)

 . S WHEN=$$FMTE^BQIUL1(WHEN)

 . S EVT=$P(^BTPW(90621,PRCN,0),U,1)

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

 . ;D FOL^BTPWPTBL(.DATA,PRCN)

 ;

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

 Q

 ;

UFOL(DATA,EVIEN,PARMS) ;EP -- BTPW UPDATE FOLLOWUP PARAMS

 ; Updates the default event due date frequency

 NEW UID,II,BN,LIST,PDATA,NAME,VALUE,VFIEN,FILE,PTYP,CHIEN,FIELD,EXEC

 NEW BQIDATA,ERROR,RESULT

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

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

 K @DATA

 ;

 S II=0

 NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIWSCHD 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 BTPWDA=$O(^BTPW(90628,1,2,"B",EVIEN,"")) I BTPWDA="" S BMXSEC="RPC Call Failed: Event does not exist." Q

 NEW DA,IENS

 S DA(1)=1,DA=BTPWDA,IENS=$$IENS^DILF(.DA),BTPWDA=IENS

 D GEN

 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

 ;

FIND(X,F) ;EP - Find an option

 S X=$O(^DIC(19,"B",X,0)) I X'>0 Q -1

 Q X

 ;

UPD(DATA,PARMS) ; EP - BTPW UPDATE SITE PARAMETERS

 NEW UID,II,BN,LIST,PDATA,NAME,VALUE,VFIEN,FILE,PTYP,CHIEN,FIELD,EXEC

 NEW BQIDATA,ERROR,RESULT

 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^BTPWSCHD 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 Site Parameters",""))

 I VFIEN="" S BMXSEC="RPC Call Failed: CMET Site Parameters Definition does not exist." Q

 S FILE=$P(^BQI(90506.3,VFIEN,0),U,2),BTPWDA=1

 D GEN

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

 Q

 ;

 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="@"

 . ;I VALUE="" Q

 . 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 @NAME=VALUE

 ;

 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)

 . S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,""))

 . I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q

 . 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 BTPWDTA(FILE,BTPWDA_",",FIELD)=@NAME

 ;

 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)

 ;

DONE ;

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

 Q

 ;

GEN ; General update code

 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="@"

 . ;I VALUE="" Q

 . 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 @NAME=VALUE

 ;

 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)

 . S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,""))

 . I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q

 . 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

 . I '$G(IENS) S IENS=BTPWDA_","

 . S BTPWDTA(FILE,IENS,FIELD)=@NAME

 ;

 S RESULT=1_U

 I $D(ERROR)>0 S RESULT=-1_U

 K ERROR

 I $D(BTPWDTA)>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)

 Q

 ;

NORM(DATA,PRCN) ; EP -- BTPW GET NORMAL FINDINGS

 NEW UID,II

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

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

 K @DATA

 ;

 S II=0

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

 ;

 S @DATA@(II)="I00010FNIEN^T00065BTPNFIND"_$C(30)

 S FN=0

 F  S FN=$O(^BTPW(90621,PRCN,6,FN)) Q:'FN  D

 . I $P(^BTPW(90621,PRCN,6,FN,0),U,2)'="N" Q

 . S IEN=$P(^BTPW(90621,PRCN,6,FN,0),U,1)

 . S II=II+1,@DATA@(II)=IEN_U_$$GET1^DIQ(90620.9,IEN_",",.01,"E")_$C(30)

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

 ;

 Q

 ;

TSK ; TASK STRUCTURE - OPTION^FREQUENCY^DOW^TIME

 ;;BTPW NIGHTLY BACKGROUND^1D^^0130

BTPWSCHD  ;VNGT/HS/ALA-CMET Scheduler ; 19 Jun 2009  9:40 AM

 +1       ;;1.0;CARE MANAGEMENT EVENT TRACKING;;Feb 07, 2011

 +2       ;

EN        ; Entry point

 +1        NEW DR,DIE,DA,DIC,DLAYGO,BI,FREQ,I,OPT,OPTN,OPTION,SAT,SUN,SDATM,SDOW,TIME,X

 +2        NEW DIFROM,CIEN,CDATM,CDATE,CTIME,DIFF,ERROR,Y,BTPWDA,ECTIME,EFREQ,BTPWDA

 +3        SET BTPWDA=1

           SET QFL=0

 +4        SET ECTIME=$$GET1^DIQ(90628,BTPWDA_",",.05,"E")

           SET EFREQ=$$GET1^DIQ(90628,BTPWDA_",",.04,"E")

 +5       ;

 +6        FOR BI=1:1

               SET OPT=$PIECE($TEXT(TSK+BI)," ;;",2,99)

               IF OPT=""

                   QUIT 

               Begin DoDot:1

 +7                SET OPTION=$PIECE(OPT,U,1)

                   SET FREQ=$PIECE(OPT,U,2)

 +8                IF EFREQ'=""

                       IF EFREQ'=FREQ

                           SET FREQ=EFREQ

 +9                IF '$$GET1^DIQ(90628,BTPWDA_",",.03,"I")

                       QUIT 

 +10               SET QFL=1

 +11               SET OPTN=$$FIND(OPTION)

                   IF OPTN'>0

                       QUIT 

 +12               IF $ORDER(^DIC(19.2,"B",OPTN,""))'=""

                       Begin DoDot:2

 +13                       SET CIEN=$ORDER(^DIC(19.2,"B",OPTN,""))

 +14                       SET CDATM=$PIECE(^DIC(19.2,CIEN,0),U,2)

 +15                       SET CDATE=$PIECE(CDATM,".",1)

                           SET CTIME=$PIECE(CDATM,".",2)

 +16                       IF ECTIME'=""

                               IF ECTIME'=CTIME

                                   SET CTIME=ECTIME

 +17                       IF CDATE>DT

                               QUIT 

 +18                       SET DIFF=$$FMDIFF^XLFDT(DT,CDATE,1)

 +19                       IF DIFF'>14

                               QUIT 

 +20                       SET SDOW=$PIECE(OPT,U,3)

                           IF SDOW'=""

                               Begin DoDot:3

 +21                               SET SAT=$$SAT^BQISCHED(DT)

 +22                               SET SUN=$$FMADD^XLFDT(SAT,1)

 +23                               IF SDOW="SAT"

                                       SET SDATM=SAT_"."_CTIME

 +24                               IF SDOW="SUN"

                                       SET SDATM=SUN_"."_CTIME

 +25                               DO RESCH^XUTMOPT(OPTION,SDATM,"",FREQ,"L",.ERROR)

                               End DoDot:3

                       End DoDot:2

                       QUIT 

 +26      ;

 +27               SET OPTION=$PIECE(OPT,U,1)

 +28      ;S FREQ=$P(OPT,U,2)

 +29               SET SDOW=$PIECE(OPT,U,3)

                   IF SDOW'=""

                       Begin DoDot:2

 +30                       SET SAT=$$SAT^BQISCHED(DT)

 +31                       SET SUN=$$FMADD^XLFDT(SAT,1)

                       End DoDot:2

 +32      ;S TIME=$P(OPT,U,4),TIME=$$STRIP^BQIUL1(TIME,"0")

 +33               SET TIME=ECTIME

                   SET TIME=$$STRIP^BQIUL1(TIME,"0")

 +34               IF SDOW=""

                       SET SDATM=$$FMADD^XLFDT(DT,1)_"."_TIME

 +35               IF SDOW="SAT"

                       SET SDATM=SAT_"."_TIME

 +36               IF SDOW="SUN"

                       SET SDATM=SUN_"."_TIME

 +37               DO RESCH^XUTMOPT(OPTION,SDATM,"",FREQ,"L",.ERROR)

 +38               KILL SDOW,SAT,SUN,TIME

               End DoDot:1

               IF 'QFL

                   QUIT 

 +39       QUIT 

 +40      ;

GET(DATA,FAKE) ;EP -- BTPW GET SITE PARAMETERS

 +1       ; Get specific CMET system parameters from the Site Parameter file

 +2        NEW UID,II,IEN,JOB,FREQ,START,DDATA

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

 +4        SET DATA=$NAME(^TMP("BTPWSCHD",UID))

 +5        KILL @DATA

 +6       ;

 +7        SET II=0

 +8       ; SAC 2006 2.2.3.3.2

           NEW $ESTACK,$ETRAP

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

 +9       ;

 +10       SET @DATA@(II)="T00003BTPWSJOB^T00004BTPWQFRQ^T00004BTPWQSTT^T00035WHO^D00030WHEN"_$CHAR(30)

 +11      ;

 +12       SET IEN=$ORDER(^BTPW(90628,0))

           IF IEN=""

               SET BMXSEC="No site defined"

               QUIT 

 +13       SET DDATA=$GET(^BTPW(90628,IEN,0))

 +14       SET JOB=$PIECE(DDATA,U,3)

 +15       SET FREQ=$PIECE(DDATA,U,4)

 +16       SET START=$PIECE(DDATA,U,5)

 +17       SET WHO=$$GET1^DIQ(90628,IEN_",",.09,"E")

 +18       SET WHEN=$$GET1^DIQ(90628,IEN_",",.1,"I")

           SET WHEN=$$FMTE^BQIUL1(WHEN)

 +19       SET II=II+1

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

 +20      ;

 +21       SET II=II+1

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

 +22       QUIT 

 +23      ;

EDUE(DATA,FAKE) ; EP -- BTPW GET EVENT DUE PARAMS

 +1       ; Retrieves the information about the default due dates

 +2        NEW UID,II,IEN,DDATA,ERDUE,ERWHEN,ERWHO,EFDUE,EFWHEN,EFWHO,ENDUE,ENWHEN,ENWHO

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

 +4        SET DATA=$NAME(^TMP("BTPWEDUE",UID))

 +5        KILL @DATA

 +6       ;

 +7        SET II=0

 +8       ; SAC 2006 2.2.3.3.2

           NEW $ESTACK,$ETRAP

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

 +9       ;

 +10       SET @DATA@(II)="T00004BTPWERDU^D00030ERWHEN^T00035ERWHO^T00004BTPWEFDU^D00030EFWHEN^"

 +11       SET @DATA@(II)=@DATA@(II)_"T00035EFWHO^T00004BTPWENDU^D00030ENWHEN^T00035ENWHO"_$CHAR(30)

 +12      ;

 +13       SET IEN=$ORDER(^BTPW(90628,0))

 +14       SET DDATA=$GET(^BTPW(90628,IEN,1))

 +15       SET ERDUE=$PIECE(DDATA,U,1)

           SET ERWHEN=$PIECE(DDATA,U,4)

           SET ERWHEN=$$FMTE^BQIUL1(ERWHEN)

 +16       SET ERWHO=$$GET1^DIQ(90628,IEN_",",1.05,"E")

 +17       SET EFDUE=$PIECE(DDATA,U,2)

           SET EFWHEN=$PIECE(DDATA,U,6)

           SET EFWHEN=$$FMTE^BQIUL1(EFWHEN)

 +18       SET EFWHO=$$GET1^DIQ(90628,IEN_",",1.07,"E")

 +19       SET ENDUE=$PIECE(DDATA,U,3)

           SET ENWHEN=$PIECE(DDATA,U,8)

           SET ENWHEN=$$FMTE^BQIUL1(ENWHEN)

 +20       SET ENWHO=$$GET1^DIQ(90628,IEN_",",1.09,"E")

 +21      ;

 +22       SET II=II+1

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

 +23      ;

 +24       SET II=II+1

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

 +25       QUIT 

 +26      ;

UDUE(DATA,PARMS) ;EP -- BTPW UPDATE EVENT DUE

 +1       ; Updates the default event due date frequency

 +2        NEW UID,II,BN,LIST,PDATA,NAME,VALUE,VFIEN,FILE,PTYP,CHIEN,FIELD,EXEC

 +3        NEW BQIDATA,ERROR,RESULT

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

 +5        SET DATA=$NAME(^TMP("BTPWUDUE",UID))

 +6        KILL @DATA

 +7       ;

 +8        SET II=0

 +9       ; SAC 2006 2.2.3.3.2

           NEW $ESTACK,$ETRAP

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

 +10       SET @DATA@(II)="I00010RESULT^T001024ERROR"_$CHAR(30)

 +11      ;

 +12       SET VFIEN=$ORDER(^BQI(90506.3,"B","CMET Event Due",""))

 +13       IF VFIEN=""

               SET BMXSEC="RPC Call Failed: CMET Event Due Definition does not exist."

               QUIT 

 +14       SET FILE=$PIECE(^BQI(90506.3,VFIEN,0),U,2)

           SET BTPWDA=1

 +15       DO GEN

 +16       SET II=II+1

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

 +17       QUIT 

 +18      ; 

FOL(DATA,FAKE) ;EP -- BTPW GET FOLLOWUP PARAMETERS

 +1       ; Returns the values for the special followup defaults

 +2        NEW UID,II,IEN,PRCN,PN,NOT,PDATA,PDATA1,WHO,WHEN,EVT,FIND

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

 +4        SET DATA=$NAME(^TMP("BTPWFOLP",UID))

 +5        KILL @DATA

 +6       ;

 +7        SET II=0

 +8       ; SAC 2006 2.2.3.3.2

           NEW $ESTACK,$ETRAP

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

 +9       ;

 +10      ;S @DATA@(II)="I00010EVIEN^T00030EVNAME^T00030BTPWPINT^T00004BTPWPFRQ^T00030EVWHOM^D00030EVWHEN"_$C(30)

 +11       SET @DATA@(II)="I00010EVIEN^T00030EVNAME^T00004BTPWPFRQ^T00030EVWHOM^D00030EVWHEN^T00030EVNOT^T00065BTPNFIND"_$CHAR(30)

 +12      ;

 +13       SET IEN=$ORDER(^BTPW(90628,0))

 +14       SET PN=0

 +15       FOR 

               SET PN=$ORDER(^BTPW(90628,IEN,2,PN))

               IF 'PN

                   QUIT 

               Begin DoDot:1

 +16               SET PDATA=^BTPW(90628,IEN,2,PN,0)

 +17               SET PRCN=$PIECE(PDATA,U,1)

                   SET FREQ=$PIECE(PDATA,U,2)

                   SET WHO=$PIECE(PDATA,U,3)

                   SET WHEN=$PIECE(PDATA,U,4)

                   SET NOT=$PIECE(PDATA,U,5)

 +18               SET PDATA1=$GET(^BTPW(90628,IEN,2,PN,1))

 +19               SET FIND=$PIECE(PDATA1,U,1)

 +20               IF WHO'=""

                       SET WHO=$PIECE(^VA(200,WHO,0),U,1)

 +21               SET WHEN=$$FMTE^BQIUL1(WHEN)

 +22               SET EVT=$PIECE(^BTPW(90621,PRCN,0),U,1)

 +23               SET II=II+1

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

 +24      ;D FOL^BTPWPTBL(.DATA,PRCN)

               End DoDot:1

 +25      ;

 +26       SET II=II+1

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

 +27       QUIT 

 +28      ;

UFOL(DATA,EVIEN,PARMS) ;EP -- BTPW UPDATE FOLLOWUP PARAMS

 +1       ; Updates the default event due date frequency

 +2        NEW UID,II,BN,LIST,PDATA,NAME,VALUE,VFIEN,FILE,PTYP,CHIEN,FIELD,EXEC

 +3        NEW BQIDATA,ERROR,RESULT

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

 +5        SET DATA=$NAME(^TMP("BTPWUFOL",UID))

 +6        KILL @DATA

 +7       ;

 +8        SET II=0

 +9       ; SAC 2006 2.2.3.3.2

           NEW $ESTACK,$ETRAP

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

 +10       SET @DATA@(II)="I00010RESULT^T001024ERROR"_$CHAR(30)

 +11      ;

 +12       SET VFIEN=$ORDER(^BQI(90506.3,"B","CMET Event Followups",""))

 +13       IF VFIEN=""

               SET BMXSEC="RPC Call Failed: CMET Event Followups Definition does not exist."

               QUIT 

 +14       SET FILE=$PIECE(^BQI(90506.3,VFIEN,0),U,2)

 +15       SET BTPWDA=$ORDER(^BTPW(90628,1,2,"B",EVIEN,""))

           IF BTPWDA=""

               SET BMXSEC="RPC Call Failed: Event does not exist."

               QUIT 

 +16       NEW DA,IENS

 +17       SET DA(1)=1

           SET DA=BTPWDA

           SET IENS=$$IENS^DILF(.DA)