| 1 | RORUTL18 ;HCIOFO/SG - MISCELLANEOUS UTILITIES ; 4/4/07 1:19pm
|
|---|
| 2 | ;;1.5;CLINICAL CASE REGISTRIES;**2**;Feb 17, 2006;Build 6
|
|---|
| 3 | ;
|
|---|
| 4 | ; This routine uses the following IA's:
|
|---|
| 5 | ;
|
|---|
| 6 | ; #10035 Access to the field #63 of the file #2
|
|---|
| 7 | ;
|
|---|
| 8 | Q
|
|---|
| 9 | ;
|
|---|
| 10 | ;***** STRIPS NON-NUMERIC CHARACTERS FROM THE LAB RESULT VALUE
|
|---|
| 11 | ;
|
|---|
| 12 | ; VAL Source value
|
|---|
| 13 | ;
|
|---|
| 14 | CLRNMVAL(VAL) ;
|
|---|
| 15 | Q $TR(VAL," <>,")
|
|---|
| 16 | ;
|
|---|
| 17 | ;***** CHECKS FOR 'CONFIRMED' STATUS
|
|---|
| 18 | ;
|
|---|
| 19 | ; IEN IEN of the registry record (in file #798)
|
|---|
| 20 | ;
|
|---|
| 21 | ; Return Values:
|
|---|
| 22 | ; 0 Not confirmed
|
|---|
| 23 | ; >0 Confirmation date/time
|
|---|
| 24 | ;
|
|---|
| 25 | CONFDT(IEN) ;
|
|---|
| 26 | N CONF S CONF=$P($G(^RORDATA(798,+IEN,0)),U,4,5)
|
|---|
| 27 | Q $S('$P(CONF,U,2):$P(CONF,U),1:0)
|
|---|
| 28 | ;
|
|---|
| 29 | ;***** DATE RANGE COMPARISON FUNCTIONS
|
|---|
| 30 | DTMAX(DT1,DT2) ;
|
|---|
| 31 | I DT1>0 Q $S(DT2>DT1:DT2,1:DT1)
|
|---|
| 32 | Q $S(DT2>0:DT2,1:0)
|
|---|
| 33 | ;
|
|---|
| 34 | DTMIN(DT1,DT2) ;
|
|---|
| 35 | I DT1>0 Q $S(DT2'>0:DT1,DT2<DT1:DT2,1:DT1)
|
|---|
| 36 | Q $S(DT2>0:DT2,1:0)
|
|---|
| 37 | ;
|
|---|
| 38 | ;***** RETURNS THE INSTITUTION IEN FOR THE HOSPITAL LOCATION
|
|---|
| 39 | ;
|
|---|
| 40 | ; IEN44 IEN in the HOSPITAL LOCATION file (#44)
|
|---|
| 41 | ;
|
|---|
| 42 | ; Return Values:
|
|---|
| 43 | ; <0 Error
|
|---|
| 44 | ; "" Location has no corresponding institution
|
|---|
| 45 | ; >0 Institution IEN
|
|---|
| 46 | ;
|
|---|
| 47 | IEN4(IEN44) ;
|
|---|
| 48 | N IEN4,RC,RORMSG
|
|---|
| 49 | Q:$G(IEN44)'>0 ""
|
|---|
| 50 | S IEN4=+$$GET1^DIQ(44,IEN44_",",3,"I",,"RORMSG")
|
|---|
| 51 | Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,,44,IEN44_",")
|
|---|
| 52 | Q $S(IEN4>0:IEN4,1:"")
|
|---|
| 53 | ;
|
|---|
| 54 | ;***** RETURNS A LAB REFERENCE (IEN IN 'LAB DATA') FOR THE PATIENT
|
|---|
| 55 | ;
|
|---|
| 56 | ; PTIEN Patient IEN
|
|---|
| 57 | ;
|
|---|
| 58 | ; Return values:
|
|---|
| 59 | ; <0 Error code
|
|---|
| 60 | ; 0 No lab data
|
|---|
| 61 | ; >0 IEN of the record in LAB DATA file
|
|---|
| 62 | ;
|
|---|
| 63 | LABREF(PTIEN) ;
|
|---|
| 64 | N LABREF,RORMSG
|
|---|
| 65 | Q:$G(PTIEN)'>0 0
|
|---|
| 66 | Q:$$MERGED(PTIEN) 0
|
|---|
| 67 | S LABREF=+$$GET1^DIQ(2,PTIEN_",",63,"I",,"RORMSG")
|
|---|
| 68 | Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,PTIEN,2,PTIEN_",")
|
|---|
| 69 | Q LABREF
|
|---|
| 70 | ;
|
|---|
| 71 | ;***** RETURNS THE NEW DFN OF A MERGED PATIENT RECORD
|
|---|
| 72 | ;
|
|---|
| 73 | ; DFN Patient IEN
|
|---|
| 74 | ;
|
|---|
| 75 | ; Return values:
|
|---|
| 76 | ; 0 The patient has not been merged
|
|---|
| 77 | ; >0 New DFN
|
|---|
| 78 | ;
|
|---|
| 79 | MERGED(DFN) ;
|
|---|
| 80 | N NEWDFN
|
|---|
| 81 | F S DFN=+$G(^DPT(+DFN,-9)) Q:DFN'>0 S NEWDFN=DFN
|
|---|
| 82 | Q +$G(NEWDFN)
|
|---|
| 83 | ;
|
|---|
| 84 | ;***** SENDS THE CPRS-COMPATIBLE INFORMATIONAL ALERT
|
|---|
| 85 | ;
|
|---|
| 86 | ; MSG Text of the alert message. The text is truncated
|
|---|
| 87 | ; to 50 characters and '^' are replaced with '~'.
|
|---|
| 88 | ;
|
|---|
| 89 | ; [DFN] Patient IEN
|
|---|
| 90 | ;
|
|---|
| 91 | ; [.XQA] List of addressees. By default, the
|
|---|
| 92 | ; alert is sent to the current user.
|
|---|
| 93 | ;
|
|---|
| 94 | ORALERT(MSG,DFN,XQA) ;
|
|---|
| 95 | N LAST4,NAME,VA,VADM,VAHOW,VAROOT,XQADATA,XQAID,XQAMSG,XQAROU
|
|---|
| 96 | S XQAMSG="",XQAID="ROR,,"
|
|---|
| 97 | I $G(DFN)>0 D
|
|---|
| 98 | . D DEM^VADPT
|
|---|
| 99 | . S NAME=$E($G(VADM(1)),1,9) ; Patient name
|
|---|
| 100 | . S LAST4=$E($P($G(VADM(2)),U),6,9) ; Last 4 of SSN
|
|---|
| 101 | . S XQAMSG=$$LJ^XLFSTR(NAME_" ("_$E(NAME,1)_LAST4_"):",19)
|
|---|
| 102 | . S $P(XQAID,",",2)=+DFN
|
|---|
| 103 | S XQAMSG=XQAMSG_$TR(MSG,"^","~")
|
|---|
| 104 | S:$L(XQAMSG)>70 $E(XQAMSG,68,999)="..."
|
|---|
| 105 | I $D(XQA)<10 Q:$G(DUZ)'>0 S XQA(+DUZ)=""
|
|---|
| 106 | D SETUP^XQALERT
|
|---|
| 107 | Q
|
|---|
| 108 | ;
|
|---|
| 109 | ;***** CHECKS FOR 'PENDING' STATUS
|
|---|
| 110 | ;
|
|---|
| 111 | ; IEN IEN of the registry record (in file #798)
|
|---|
| 112 | ;
|
|---|
| 113 | ; Return Values:
|
|---|
| 114 | ; 0 Non-pending
|
|---|
| 115 | ; 1 Pending patient
|
|---|
| 116 | ;
|
|---|
| 117 | PENDING(IEN) ;
|
|---|
| 118 | Q ($P($G(^RORDATA(798,+IEN,0)),U,5)=4)
|
|---|
| 119 | ;
|
|---|
| 120 | ;***** EMULATES $QUERY WITH 'DIRECTION' PARAMETER
|
|---|
| 121 | ;
|
|---|
| 122 | ; NODE Closed root of a node
|
|---|
| 123 | ;
|
|---|
| 124 | ; [DIR] Direction:
|
|---|
| 125 | ; $G(DIR)'<0 forward
|
|---|
| 126 | ; DIR<0 backward
|
|---|
| 127 | ;
|
|---|
| 128 | Q(NODE,DIR) ;
|
|---|
| 129 | Q:$G(DIR)'<0 $Q(@NODE)
|
|---|
| 130 | N I,DN,PI,TMP
|
|---|
| 131 | S TMP=$QL(NODE) Q:TMP'>0 ""
|
|---|
| 132 | S I=$QS(NODE,TMP),NODE=$NA(@NODE,TMP-1)
|
|---|
| 133 | S PI=""
|
|---|
| 134 | F S I=$O(@NODE@(I),-1) Q:I="" D Q:PI'=""
|
|---|
| 135 | . S DN=$D(@NODE@(I))
|
|---|
| 136 | . I DN#10 S PI=$NA(@NODE@(I)) Q
|
|---|
| 137 | . S:DN>1 PI=$$Q($NA(@NODE@(I,"")),-1)
|
|---|
| 138 | Q PI
|
|---|
| 139 | ;
|
|---|
| 140 | ;***** COUNTS THE REGISTRY PATIENTS
|
|---|
| 141 | ;
|
|---|
| 142 | ; .REGLST Reference to a local array containing registry
|
|---|
| 143 | ; names as the subscripts and optional registry IENs
|
|---|
| 144 | ; as the values.
|
|---|
| 145 | ;
|
|---|
| 146 | ; [FLAGS] Flags (can be combined)
|
|---|
| 147 | ; A Skip non-active patients
|
|---|
| 148 | ; S Skip patients marked as "Do not Send"
|
|---|
| 149 | ;
|
|---|
| 150 | ; [ROR8DST] Closed root of the global node that will contain a
|
|---|
| 151 | ; list of patients. By default ($G(ROR8DST)=""), the
|
|---|
| 152 | ; ^TMP("RORUTL18",$J) global node is used internally
|
|---|
| 153 | ; (it is deleted before exiting the function).
|
|---|
| 154 | ; @ROR8DST@(
|
|---|
| 155 | ; PatIEN,
|
|---|
| 156 | ; RegIEN) Registry Record IEN
|
|---|
| 157 | ;
|
|---|
| 158 | ; Return Values:
|
|---|
| 159 | ; <0 Error code
|
|---|
| 160 | ; 0 All provided registries are empty
|
|---|
| 161 | ; >0 Number of unique patients
|
|---|
| 162 | ;
|
|---|
| 163 | REGPTCNT(REGLST,FLAGS,ROR8DST) ;
|
|---|
| 164 | N CNT,IEN,NODE,PLKILL,PTIEN,REGIEN,REGNAME
|
|---|
| 165 | S:$G(ROR8DST)="" ROR8DST=$NA(^TMP("RORUTL18",$J)),PLKILL=1
|
|---|
| 166 | S FLAGS=$G(FLAGS),NODE=$$ROOT^DILFD(798,"",1),CNT=0
|
|---|
| 167 | K @ROR8DST
|
|---|
| 168 | ;--- Build a list of unique patients and count them
|
|---|
| 169 | S REGNAME=""
|
|---|
| 170 | F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D
|
|---|
| 171 | . ;--- Get the registry IEN
|
|---|
| 172 | . S REGIEN=+$G(REGLST(REGNAME))
|
|---|
| 173 | . I REGIEN'>0 D Q:REGIEN'>0
|
|---|
| 174 | . . S REGIEN=$$REGIEN^RORUTL02(REGNAME)
|
|---|
| 175 | . ;--- Count the registry patients
|
|---|
| 176 | . S IEN=0
|
|---|
| 177 | . F S IEN=$O(@NODE@("AC",REGIEN,IEN)) Q:IEN'>0 D
|
|---|
| 178 | . . I FLAGS["A" Q:'$$ACTIVE^RORDD(IEN)
|
|---|
| 179 | . . I FLAGS["S" Q:$P($G(^RORDATA(798,IEN,2)),U,4)
|
|---|
| 180 | . . S PTIEN=$$PTIEN^RORUTL01(IEN) Q:PTIEN'>0
|
|---|
| 181 | . . I '$D(@ROR8DST@(PTIEN)) D S CNT=CNT+1
|
|---|
| 182 | . . . S @ROR8DST@(PTIEN,REGIEN)=IEN
|
|---|
| 183 | ;--- Cleanup
|
|---|
| 184 | K:$G(PLKILL) @ROR8DST
|
|---|
| 185 | Q CNT
|
|---|
| 186 | ;
|
|---|
| 187 | ;***** SELECTS A REGISTRY DESCRIPTOR IN THE FILE #798.1
|
|---|
| 188 | ;
|
|---|
| 189 | ; [.REGNAME] Registry name is returned via this parameter
|
|---|
| 190 | ;
|
|---|
| 191 | ; Return Values:
|
|---|
| 192 | ; <0 Error code
|
|---|
| 193 | ; "" Timeout, "^" entered, or an error in ^DIC
|
|---|
| 194 | ; 0 There are no records in the file #798.1
|
|---|
| 195 | ; >0 IEN of the selected registry
|
|---|
| 196 | ;
|
|---|
| 197 | SELREG(REGNAME) ;
|
|---|
| 198 | N DA,DIC,DLAYGO,DTOUT,DUOUT,RC,RORBUF,RORMSG,X,Y
|
|---|
| 199 | S REGNAME=""
|
|---|
| 200 | ;--- If there are less than two records, do not ask a user
|
|---|
| 201 | D LIST^DIC(798.1,,"@;.01E",,2,,,"B",,,"RORBUF","RORMSG")
|
|---|
| 202 | Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,,798.1)
|
|---|
| 203 | I $G(RORBUF("DILIST",0))<2 D Q +$G(RORBUF("DILIST",2,1))
|
|---|
| 204 | . S REGNAME=$G(RORBUF("DILIST","ID",1,.01))
|
|---|
| 205 | ;--- Select a registry
|
|---|
| 206 | S DIC=798.1,DIC(0)="AENQZ"
|
|---|
| 207 | S DIC("A")="Select a Registry: "
|
|---|
| 208 | D ^DIC
|
|---|
| 209 | S:Y>0 REGNAME=Y(0,0)
|
|---|
| 210 | Q $S($D(DTOUT)!$D(DUOUT):"",Y<0:"",1:+Y)
|
|---|
| 211 | ;
|
|---|
| 212 | ;***** RETURNS THE CLINIC'S STOP CODE
|
|---|
| 213 | ;
|
|---|
| 214 | ; CLIEN Clinic IEN
|
|---|
| 215 | ;
|
|---|
| 216 | ; Return Values:
|
|---|
| 217 | ; <0 Error code
|
|---|
| 218 | ; "" No stop code
|
|---|
| 219 | ; >0 Stop code
|
|---|
| 220 | ;
|
|---|
| 221 | STOPCODE(CLIEN) ;
|
|---|
| 222 | N RORMSG,STOP
|
|---|
| 223 | I CLIEN>0 D
|
|---|
| 224 | . S STOP=$$GET1^DIQ(44,CLIEN_",","#8:#1","I",,"RORMSG")
|
|---|
| 225 | . S:$G(DIERR) STOP=$$DBS^RORERR("RORMSG",-99,,,44,CLIEN_",")
|
|---|
| 226 | E S STOP=""
|
|---|
| 227 | Q STOP
|
|---|
