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)
SET BTPWDA=IENS
+18 DO GEN
+19 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+20 QUIT
+21 ;
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 ;
FIND(X,F) ;EP - Find an option
+1 SET X=$ORDER(^DIC(19,"B",X,0))
IF X'>0
QUIT -1
+2 QUIT X
+3 ;
UPD(DATA,PARMS) ; EP - BTPW UPDATE SITE PARAMETERS
+1 NEW UID,II,BN,LIST,PDATA,NAME,VALUE,VFIEN,FILE,PTYP,CHIEN,FIELD,EXEC
+2 NEW BQIDATA,ERROR,RESULT
+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^BTPWSCHD D UNWIND^%ZTER"
+9 SET @DATA@(II)="I00010RESULT^T001024ERROR"_$CHAR(30)
+10 ;
+11 SET VFIEN=$ORDER(^BQI(90506.3,"B","CMET Site Parameters",""))
+12 IF VFIEN=""
SET BMXSEC="RPC Call Failed: CMET Site Parameters Definition does not exist."
QUIT
+13 SET FILE=$PIECE(^BQI(90506.3,VFIEN,0),U,2)
SET BTPWDA=1
+14 DO GEN
+15 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+16 QUIT
+17 ;
+18 SET PARMS=$GET(PARMS,"")
+19 IF PARMS=""
Begin DoDot:1
+20 SET LIST=""
SET BN=""
+21 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+22 KILL PARMS
+23 SET PARMS=LIST
+24 KILL LIST
End DoDot:1
+25 ;
+26 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+27 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+28 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+29 IF VALUE=""
SET VALUE="@"
+30 ;I VALUE="" Q
+31 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
+32 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+33 SET PTYP=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
+34 IF PTYP="D"
SET VALUE=$$DATE^BQIUL1(VALUE)
+35 IF PTYP="C"
Begin DoDot:2
+36 SET CHIEN=$ORDER(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,""))
IF CHIEN=""
QUIT
+37 SET VALUE=$PIECE(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
End DoDot:2
+38 SET @NAME=VALUE
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+39 ;
+40 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+41 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+42 SET NAME=$PIECE(PDATA,"=",1)
+43 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
+44 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+45 SET FIELD=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
+46 SET EXEC=$GET(^BQI(90506.3,VFIEN,10,PFIEN,7))
+47 IF EXEC'=""
XECUTE EXEC
QUIT
+48 IF FIELD=""
QUIT
+49 SET BTPWDTA(FILE,BTPWDA_",",FIELD)=@NAME
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+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 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
GEN ; General update code
+1 SET PARMS=$GET(PARMS,"")
+2 IF PARMS=""
Begin DoDot:1
+3 SET LIST=""
SET BN=""
+4 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+5 KILL PARMS
+6 SET PARMS=LIST
+7 KILL LIST
End DoDot:1
+8 ;
+9 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+10 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+11 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+12 IF VALUE=""
SET VALUE="@"
+13 ;I VALUE="" Q
+14 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
+15 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+16 SET PTYP=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,1)),U,1)
+17 IF PTYP="D"
SET VALUE=$$DATE^BQIUL1(VALUE)
+18 IF PTYP="C"
Begin DoDot:2
+19 SET CHIEN=$ORDER(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,""))
IF CHIEN=""
QUIT
+20 SET VALUE=$PIECE(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
End DoDot:2
+21 SET @NAME=VALUE
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+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)
+26 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
+27 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+28 SET FIELD=$PIECE($GET(^BQI(90506.3,VFIEN,10,PFIEN,3)),U,1)
+29 SET EXEC=$GET(^BQI(90506.3,VFIEN,10,PFIEN,7))
+30 IF EXEC'=""
XECUTE EXEC
QUIT
+31 IF FIELD=""
QUIT
+32 IF '$GET(IENS)
SET IENS=BTPWDA_","
+33 SET BTPWDTA(FILE,IENS,FIELD)=@NAME
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+34 ;
+35 SET RESULT=1_U
+36 IF $DATA(ERROR)>0
SET RESULT=-1_U
+37 KILL ERROR
+38 IF $DATA(BTPWDTA)>0
DO FILE^DIE("","BTPWDTA","ERROR")
+39 IF $DATA(ERROR)>0
SET RESULT=-1_U_$GET(ERROR("DIERR",1,"TEXT",1))
+40 IF $PIECE(RESULT,U,1)'=-1
SET RESULT=1_U
+41 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+42 QUIT
+43 ;
NORM(DATA,PRCN) ; EP -- BTPW GET NORMAL FINDINGS
+1 NEW UID,II
+2 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+3 SET DATA=$NAME(^TMP("BTPWNORM",UID))
+4 KILL @DATA
+5 ;
+6 SET II=0
+7 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BTPWSCHD D UNWIND^%ZTER"
+8 ;
+9 SET @DATA@(II)="I00010FNIEN^T00065BTPNFIND"_$CHAR(30)
+10 SET FN=0
+11 FOR
SET FN=$ORDER(^BTPW(90621,PRCN,6,FN))
IF 'FN
QUIT
Begin DoDot:1
+12 IF $PIECE(^BTPW(90621,PRCN,6,FN,0),U,2)'="N"
QUIT
+13 SET IEN=$PIECE(^BTPW(90621,PRCN,6,FN,0),U,1)
+14 SET II=II+1
SET @DATA@(II)=IEN_U_$$GET1^DIQ(90620.9,IEN_",",.01,"E")_$CHAR(30)
End DoDot:1
+15 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+16 ;
+17 QUIT
+18 ;
TSK ; TASK STRUCTURE - OPTION^FREQUENCY^DOW^TIME
+1 ;;BTPW NIGHTLY BACKGROUND^1D^^0130
