| [613] | 1 | RORUTL01 ;HCIOFO/SG - UTILITIES ; 5/12/05 3:29pm
|
|---|
| 2 | ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
|
|---|
| 3 | ;
|
|---|
| 4 | ; This routine uses the following IAs:
|
|---|
| 5 | ;
|
|---|
| 6 | ; #3301 Access to the .6 field of the file #2
|
|---|
| 7 | ; #3744 $$TESTPAT^VADPT
|
|---|
| 8 | ; #10035 Access to the .01 and .09 fields of the file #2
|
|---|
| 9 | ; #10038 Access to the HOLIDAY file (supported)
|
|---|
| 10 | Q
|
|---|
| 11 | ;
|
|---|
| 12 | ;***** SENDS ALERT TO REGISTRY COORDINATORS
|
|---|
| 13 | ;
|
|---|
| 14 | ; [.]REGLST Either name of the registry or reference to a local
|
|---|
| 15 | ; array containing registry names as subscripts and
|
|---|
| 16 | ; optional registry IENs as values
|
|---|
| 17 | ;
|
|---|
| 18 | ; MSG Text of the message or negative error code. The '^'
|
|---|
| 19 | ; characters are replaced with spaces in the text.
|
|---|
| 20 | ;
|
|---|
| 21 | ; [XQAROU] Indicates a ROUTINE or TAG^ROUTINE to run when
|
|---|
| 22 | ; the alert is processed
|
|---|
| 23 | ;
|
|---|
| 24 | ; [XQADATA] Use this to store a package-specific data string,
|
|---|
| 25 | ; in any format
|
|---|
| 26 | ;
|
|---|
| 27 | ; [PATIEN] Patient IEN
|
|---|
| 28 | ;
|
|---|
| 29 | ; [ARG2-ARG5] Optional parameters as for the $$ERROR^RORERR
|
|---|
| 30 | ;
|
|---|
| 31 | ALERT(REGLST,MSG,XQAROU,XQADATA,PATIEN,ARG2,ARG3,ARG4,ARG5) ;
|
|---|
| 32 | N IR,RC,REGIEN,REGNAME,RORBUF,RORMSG,TMP,XQA,XQAFLG,XQAMSG
|
|---|
| 33 | ;--- Prepare the notification list
|
|---|
| 34 | I $D(REGLST)=1 Q:REGLST="" S REGLST(REGLST)=""
|
|---|
| 35 | S REGNAME="",RC=0
|
|---|
| 36 | F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D
|
|---|
| 37 | . S REGIEN=+$G(REGLST(REGNAME))
|
|---|
| 38 | . I REGIEN'>0 D Q:REGIEN'>0
|
|---|
| 39 | . . S REGIEN=$$REGIEN^RORUTL02(REGNAME)
|
|---|
| 40 | . ;--- Load the notification list from the registry parameters
|
|---|
| 41 | . K RORBUF S TMP=","_REGIEN_","
|
|---|
| 42 | . D LIST^DIC(798.114,TMP,"@;.01I","U",,,,"B",,,"RORBUF","RORMSG")
|
|---|
| 43 | . S RC=$$DBS^RORERR("RORMSG",-9) Q:RC<0
|
|---|
| 44 | . S IR=""
|
|---|
| 45 | . F S IR=$O(RORBUF("DILIST","ID",IR)) Q:IR="" D
|
|---|
| 46 | . . S TMP=+$G(RORBUF("DILIST","ID",IR,.01)) S:TMP>0 XQA(TMP)=""
|
|---|
| 47 | Q:$D(XQA)<10
|
|---|
| 48 | ;--- Get text of the error message (if necessary)
|
|---|
| 49 | I +MSG=MSG Q:MSG'<0 D
|
|---|
| 50 | . S MSG=$$MSG^RORERR20(+MSG,,.PATIEN,.ARG2,.ARG3,.ARG4,.ARG5)
|
|---|
| 51 | S MSG=$TR(MSG,"^"," "),XQAMSG="ROR: ",TMP=70-$L(XQAMSG)-3
|
|---|
| 52 | S XQAMSG=XQAMSG_$S($L(MSG)>TMP:$E(MSG,1,TMP)_"...",1:MSG)
|
|---|
| 53 | ;--- Setup default alert processing routine
|
|---|
| 54 | I $G(XQAROU)="",$G(XQADATA)="" D
|
|---|
| 55 | . S XQADATA=$E(MSG,1,78)_U_$G(PATIEN)
|
|---|
| 56 | . S REGNAME=""
|
|---|
| 57 | . F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D
|
|---|
| 58 | . . S XQADATA=XQADATA_U_REGNAME
|
|---|
| 59 | . S XQAROU="ALERTRTN^RORUTL01"
|
|---|
| 60 | ;--- Send the alert
|
|---|
| 61 | S XQAFLG="D" D SETUP^XQALERT
|
|---|
| 62 | Q
|
|---|
| 63 | ;
|
|---|
| 64 | ;***** DEFAULT ALERT PROCESSING ROUTINE
|
|---|
| 65 | ;
|
|---|
| 66 | ; XQADATA Alert data
|
|---|
| 67 | ; ^1: Message
|
|---|
| 68 | ; ^2: Patient DFN
|
|---|
| 69 | ; ^3: Registry name
|
|---|
| 70 | ; ...
|
|---|
| 71 | ; ^N: Registry name
|
|---|
| 72 | ;
|
|---|
| 73 | ALERTRTN ;
|
|---|
| 74 | Q:$G(XQADATA)=""
|
|---|
| 75 | N I,REGNAME
|
|---|
| 76 | W !!,$P(XQADATA,"^"),!
|
|---|
| 77 | W:$P(XQADATA,"^",2) "Patient DFN: ",$P(XQADATA,"^",2),!
|
|---|
| 78 | W "Processed Registries",!
|
|---|
| 79 | F I=3:1 S REGNAME=$P(XQADATA,"^",I) Q:REGNAME="" W ?3,REGNAME,!
|
|---|
| 80 | Q
|
|---|
| 81 | ;
|
|---|
| 82 | ;***** INITIALIZES THE VARIABLES
|
|---|
| 83 | ;
|
|---|
| 84 | ; NAMESP Namespace to kill in the ^TMP global
|
|---|
| 85 | ; (must start with "ROR")
|
|---|
| 86 | ; [XPURGE] Purge namespaced nodes in the ^XTMP global.
|
|---|
| 87 | ; The ^XTMP(NAMESP_$J) node is always killed.
|
|---|
| 88 | ;
|
|---|
| 89 | INIT(NAMESP,XPURGE) ;
|
|---|
| 90 | N I,L,NOW K ^TMP($J)
|
|---|
| 91 | S:$G(U)="" U="^" S:'$G(DT) DT=$$DT^XLFDT
|
|---|
| 92 | Q:$E($G(NAMESP),1,3)'="ROR"
|
|---|
| 93 | ;--- Kill namespaced nodes in the ^TMP global
|
|---|
| 94 | S I=NAMESP,L=$L(NAMESP)
|
|---|
| 95 | F K ^TMP(I,$J) S I=$O(^TMP(I)) Q:$E(I,1,L)'=NAMESP
|
|---|
| 96 | ;--- Purge old namespaced nodes in the ^XTMP global
|
|---|
| 97 | K ^XTMP(NAMESP_$J)
|
|---|
| 98 | D:$G(XPURGE)
|
|---|
| 99 | . S NOW=$$NOW^XLFDT,I=NAMESP,L=$L(NAMESP)
|
|---|
| 100 | . F D S I=$O(^XTMP(I)) Q:$E(I,1,L)'=NAMESP
|
|---|
| 101 | . . K:$G(^XTMP(I,0))<NOW ^XTMP(I)
|
|---|
| 102 | Q
|
|---|
| 103 | ;
|
|---|
| 104 | ;***** INVERTS THE DATE
|
|---|
| 105 | ;
|
|---|
| 106 | ; DATE Date in FileMan format
|
|---|
| 107 | ; [MODE] Mode of inversion
|
|---|
| 108 | ; 1 Strip the time BEFORE inversion
|
|---|
| 109 | ; 2 Strip the time AFTER inversion
|
|---|
| 110 | ; 3 Do not invert the time
|
|---|
| 111 | ;
|
|---|
| 112 | INVDATE(DATE,MODE) ;
|
|---|
| 113 | Q:$G(MODE)=1 9999999-$P(DATE,".")
|
|---|
| 114 | Q:$G(MODE)=2 $P(9999999-DATE,".")
|
|---|
| 115 | I $G(MODE)=3 Q:$P(DATE,".",2) (9999999-$P(DATE,"."))_"."_+$P(DATE,".",2)
|
|---|
| 116 | Q 9999999-DATE
|
|---|
| 117 | ;
|
|---|
| 118 | ;***** RETURNS THE PATIENT IEN (DFN) FROM THE REGISTRY RECORD
|
|---|
| 119 | ;
|
|---|
| 120 | ; IEN IEN of the registry record
|
|---|
| 121 | ;
|
|---|
| 122 | PTIEN(IEN) ;
|
|---|
| 123 | Q +$P($G(^RORDATA(798,+IEN,0)),U)
|
|---|
| 124 | ;
|
|---|
| 125 | ;***** RETURNS IEN OF THE PATIENT'S RECORD IN THE REGISTRY
|
|---|
| 126 | ;
|
|---|
| 127 | ; PATIEN Patient IEN
|
|---|
| 128 | ; REGIEN Registry IEN
|
|---|
| 129 | ;
|
|---|
| 130 | ; Return Values:
|
|---|
| 131 | ; "" The registry record has not been found
|
|---|
| 132 | ; >0 IEN of the patient's registry record
|
|---|
| 133 | ;
|
|---|
| 134 | PRRIEN(PATIEN,REGIEN) ;
|
|---|
| 135 | Q:(PATIEN'>0)!(REGIEN'>0) 0
|
|---|
| 136 | Q $O(^RORDATA(798,"KEY",+PATIEN,+REGIEN,0))
|
|---|
| 137 | ;
|
|---|
| 138 | ;***** RETURNS NAME AND SHORT DESCRIPTION OF THE REGISTRY
|
|---|
| 139 | ;
|
|---|
| 140 | ; REGIEN Registry IEN
|
|---|
| 141 | ;
|
|---|
| 142 | ; Return Values:
|
|---|
| 143 | ;
|
|---|
| 144 | ; An empty string is returned in case of an error or if there
|
|---|
| 145 | ; is no registry with such IEN. Otherwise, the name and short
|
|---|
| 146 | ; description of the registry separated by "^" are returned.
|
|---|
| 147 | ;
|
|---|
| 148 | REGNAME(REGIEN) ;
|
|---|
| 149 | N IENS,NAME,RORBUF,RORMSG
|
|---|
| 150 | Q:'$D(^ROR(798.1,+REGIEN)) ""
|
|---|
| 151 | S IENS=+REGIEN_","
|
|---|
| 152 | D GETS^DIQ(798.1,IENS,".01;4",,"RORBUF","RORMSG")
|
|---|
| 153 | I $G(DIERR) D Q ""
|
|---|
| 154 | . D DBS^RORERR("RORMSG",-9,,,798.1,IENS)
|
|---|
| 155 | Q RORBUF(798.1,IENS,.01)_U_$G(RORBUF(798.1,IENS,4))
|
|---|
| 156 | ;
|
|---|
| 157 | ;***** CHECKS IF THE PATIENT IS A TEST ONE
|
|---|
| 158 | ;
|
|---|
| 159 | ; PATIEN Patient IEN
|
|---|
| 160 | ;
|
|---|
| 161 | ; Return Values:
|
|---|
| 162 | ; 0 The patient is NOT a test patient
|
|---|
| 163 | ; 1 The patient IS a test patient
|
|---|
| 164 | ;
|
|---|
| 165 | TESTPAT(PATIEN) ;
|
|---|
| 166 | Q:$$TESTPAT^VADPT(PATIEN) 1
|
|---|
| 167 | Q:$E($G(^DPT(PATIEN,0)),1,2)="ZZ" 1 ; NAME starts with "ZZ"
|
|---|
| 168 | Q 0
|
|---|
| 169 | ;
|
|---|
| 170 | ;***** VERIFY THE ENTRY POINT
|
|---|
| 171 | ;
|
|---|
| 172 | ; ENTRY Entry point of the external MUMPS function
|
|---|
| 173 | ; [RECERR] Record the errors (do not record by default)
|
|---|
| 174 | ;
|
|---|
| 175 | ; Return Values:
|
|---|
| 176 | ; -18 Routine does not exist
|
|---|
| 177 | ; -17 Invalid entry point
|
|---|
| 178 | ; 0 Ok
|
|---|
| 179 | ;
|
|---|
| 180 | VERIFYEP(ENTRY,RECERR) ;
|
|---|
| 181 | N X
|
|---|
| 182 | S X="S Y="_ENTRY D ^DIM
|
|---|
| 183 | Q:'$D(X) $S($G(RECERR):$$ERROR^RORERR(-17,,,,ENTRY),1:-17)
|
|---|
| 184 | S X=$P(ENTRY,U,2)
|
|---|
| 185 | X ^%ZOSF("TEST") E Q $S($G(RECERR):$$ERROR^RORERR(-18,,,,X),1:-18)
|
|---|
| 186 | Q 0
|
|---|
| 187 | ;
|
|---|
| 188 | ;***** CHECKS IF THE DATE IS A WORKING DAY
|
|---|
| 189 | ;
|
|---|
| 190 | ; DATE The date to be checked
|
|---|
| 191 | ;
|
|---|
| 192 | ; Return Values:
|
|---|
| 193 | ; 0 Weekend or Holiday
|
|---|
| 194 | ; 1 Working day
|
|---|
| 195 | ;
|
|---|
| 196 | WDCHK(DATE) ;
|
|---|
| 197 | N DOW,RORMSG
|
|---|
| 198 | ;--- Return zero if Saturday (6) or Sunday (0)
|
|---|
| 199 | S DOW=$$DOW^XLFDT(DATE,1) Q:'DOW!(DOW>5) 0
|
|---|
| 200 | ;--- Return 1 if cannot be found in the HOLIDAY file
|
|---|
| 201 | Q $$FIND1^DIC(40.5,,"QX",DATE\1,"B",,"RORMSG")'>0
|
|---|
| 202 | ;
|
|---|
| 203 | ;***** RETURNS THE NEXT WORKING DAY DATE
|
|---|
| 204 | ;
|
|---|
| 205 | ; DATE The source date
|
|---|
| 206 | ;
|
|---|
| 207 | ; The function returns a date of the next working day.
|
|---|
| 208 | ;
|
|---|
| 209 | WDNEXT(DATE) ;
|
|---|
| 210 | N DOW,RORMSG
|
|---|
| 211 | F D Q:$$FIND1^DIC(40.5,,"QX",DATE,"B",,"RORMSG")'>0
|
|---|
| 212 | . S DOW=$$DOW^XLFDT(DATE,1) S:'DOW DOW=7
|
|---|
| 213 | . ;--- Get the next day and skip a weekend if necessary
|
|---|
| 214 | . S DATE=$$FMADD^XLFDT(DATE,$S(DOW<5:1,1:8-DOW))
|
|---|
| 215 | Q DATE
|
|---|
| 216 | ;
|
|---|
| 217 | ;***** CREATES A HEADER OF THE NODE IN THE ^XTMP GLOBAL
|
|---|
| 218 | ;
|
|---|
| 219 | ; SUBSCR Subscript of the node in the ^XTMP global
|
|---|
| 220 | ; [DKEEP] Number of days to keep the node (1 by default)
|
|---|
| 221 | ; [DESCR] Description of the node
|
|---|
| 222 | ;
|
|---|
| 223 | XTMPHDR(SUBSCR,DKEEP,DESCR) ;
|
|---|
| 224 | N DATE S DATE=$$DT^XLFDT S:$G(DKEEP)'>0 DKEEP=1
|
|---|
| 225 | S ^XTMP(SUBSCR,0)=$$FMADD^XLFDT(DATE,DKEEP)_U_DATE_U_$G(DESCR)
|
|---|
| 226 | Q
|
|---|
| 227 | ;
|
|---|
| 228 | ;***** EMULATES AND EXTENDS THE ZWRITE COMMAND :-)
|
|---|
| 229 | ;
|
|---|
| 230 | ; ROR8NODE Closed root of the sub-tree to display
|
|---|
| 231 | ; (either local array or global variable)
|
|---|
| 232 | ; [TITLE] Title of the output
|
|---|
| 233 | ;
|
|---|
| 234 | ZW(ROR8NODE,TITLE) ;
|
|---|
| 235 | Q:ROR8NODE="" Q:'$D(@ROR8NODE)
|
|---|
| 236 | N FLT,L,PI W !
|
|---|
| 237 | W:$G(TITLE)'="" TITLE,!!
|
|---|
| 238 | W:$D(@ROR8NODE)#10 ROR8NODE_"="_@ROR8NODE,!
|
|---|
| 239 | S L=$L(ROR8NODE) S:$E(ROR8NODE,L)=")" L=L-1
|
|---|
| 240 | S FLT=$E(ROR8NODE,1,L),PI=ROR8NODE
|
|---|
| 241 | F S PI=$Q(@PI) Q:$E(PI,1,L)'=FLT W PI_"="_@PI,!
|
|---|
| 242 | Q
|
|---|
