Changeset 623 for WorldVistAEHR/trunk/r/CLINICAL_PROCEDURES-MD
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- Location:
- WorldVistAEHR/trunk/r/CLINICAL_PROCEDURES-MD
- Files:
-
- 8 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/CLINICAL_PROCEDURES-MD/MDAPI.m
r613 r623 1 MDAPI ; HOIFO/DP/NCA - CP API Calls ; [05-05-2003 10:28] 2 ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102 3 ; Description: 4 ; These API's are for use by external packages communicating with CP. 5 ; 6 ; Integration Agreements: 7 ; IA# 3378 [Subscription] Documents the APIs that external packages use to communicate with CP. 8 ; IA# 3468 [Subscription] Use GMRCCP APIs. 9 ; 10 EXTDATA(MDPROC) ; [Procedure] 11 ; Returns 0/1 for external data needed 12 ; Called by Consults to determine status of consult ordered 13 ; 14 ; Input parameters 15 ; 1. MDPROC [Literal/Required] CP Definition IEN 16 ; 17 Q:'$D(^MDS(702.01,+$G(MDPROC),0)) 0 18 I +$P(^MDS(702.01,+$G(MDPROC),0),U,3)!($O(^(.1,0))) Q 1 19 E Q 0 20 ; 21 ISTAT(MDARR) ; [Procedure] Called by Imaging to update status 22 ; Input parameters 23 ; 1. MDARR [Literal/Required] Array from Imaging 24 ; 25 ; Input: MDARR(0)="0^error message" or "1^success message" 26 ; MDARR(1)=TrackID (CP;Transaction IEN) 27 ; MDARR(2)=Queue Number 28 ; MDARR(3..N)=Warnings 29 N MDCON,MDCR,MDIEN,MDIENS,MDLP,MDSTAT,MDSTR,MDTIU,RESULTS 30 Q:$G(MDARR(0))="" 31 Q:$G(MDARR(1))="" 32 Q:$P(MDARR(1),";")'="CP" 33 Q:'(+$P(MDARR(1),";",2)) 34 S MDIEN=+$P(MDARR(1),";",2),MDIENS=MDIEN_"," 35 S MDSTAT=+$P(MDARR(0),"^") 36 S DATA("TRANSACTION")=MDIEN 37 ; Is it in error? 38 I 'MDSTAT D Q 39 .D STATUS^MDRPCOT(MDIENS,2,$P(MDARR(0),"^",2)) 40 .S DATA("PKG")="IMAGING" 41 .S DATA("MESSAGE")=$P(MDARR(0),"^",2) D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA) 42 .F MDLP=2:0 S MDLP=$O(MDARR(MDLP)) Q:'MDLP I $G(MDARR(MDLP))'="" D 43 ..S DATA("MESSAGE")=$$TRANS(MDARR(MDLP)) D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA) 44 .D IMGSTAT^MDRPCOT1(+MDIENS,2) Q 45 ; Call Consults that Partial Result ready 46 S MDCON=+$P(^MDD(702,MDIEN,0),"^",5),MDTIU=+$P(^(0),"^",6) 47 S MDCR=$$UPDCONS^MDRPCOT1(MDCON,MDTIU) 48 I +MDCR<0 D Q 49 .D STATUS^MDRPCOT(MDIENS,2,$P(MDCR,"^",2)) 50 .S DATA("PKG")="CONSULTS",DATA("MESSAGE")=$P(MDCR,"^",2) 51 .D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA) 52 .Q 53 ; Closeout the record 54 D STATUS^MDRPCOT(MDIENS,3,"") 55 ; Update Images Status 56 D IMGSTAT^MDRPCOT1(+MDIENS,3) 57 Q 58 ; 59 ITIU(RESULTS,DFN,CONSULT,VSTRING) ; [Procedure] API for Vista Imaging 60 ; This API enables VistA Imaging to retrieve/create a TIU note for 61 ; a consult for attaching images to. 62 ; 63 ; RESULTS(0) will equal one of the following 64 ; IEN of the TIU note if successful 65 ; or on failure one of the following status messages 66 ; -1^No patient DFN 67 ; -1^No Consult IEN 68 ; -1^No VString 69 ; -1^Error in CP transaction 70 ; -1^Unable to create CP transaction 71 ; -1^Unable to create the TIU document 72 ; -1^No such consult for this patient. 73 ; 74 ; Input parameters 75 ; 1. RESULTS [Reference/Required] Return array 76 ; 2. DFN [Literal/Required] Patient IEN 77 ; 3. CONSULT [Literal/Required] Consult IEN 78 ; 4. VSTRING [Literal/Optional] VString data for TIU Note (Required to create new TIU note) 79 ; 80 ; Variables: 81 ; MDIEN: [Private] Returns IEN from UPDATE~DIE call 82 ; MDIENS: [Private] Scratch 83 ; MDNOTE: [Private] Scratch 84 ; MDTRANS: [Private] Contains IEN of CP transaction 85 ; 86 ; New private variables 87 NEW MDIEN,MDIENS,MDNOTE,MDTRANS 88 K ^TMP($J),^TMP("MDTIUST",$J) 89 N MDD,MDN,MDTIUER,MDTST,MDNEWV,MDTIUD S (MDTIUD,MDTIUER,MDTST)="" 90 I '$G(DFN) S RESULTS(0)="-1^No patient DFN" Q 91 I '$G(CONSULT) S RESULTS(0)="-1^No Consult IEN" Q 92 ; Look for existing transaction 93 S MDTIUD=$$PREV^MDRPCOT(+CONSULT,"") 94 I +MDTIUD S RESULTS(0)=+MDTIUD Q 95 ; No transaction, must create one for this consult 96 I $G(VSTRING)="" S RESULTS(0)="-1^No VString" Q 97 D CPLIST^GMRCCP(DFN,,$NA(^TMP($J))) 98 S MDX="" F S MDX=$O(^TMP($J,MDX)) Q:'MDX I $P(^(MDX),U,5)=CONSULT D Q 99 .D NOW^%DTC S MDD=% 100 .S:$L(VSTRING,";")=1 VSTRING=";"_VSTRING 101 .S MDNEWV=$$GETVSTR^MDRPCOT1(DFN,VSTRING,$P(^TMP($J,MDX),U,6),MDD) 102 .S MDFDA(702,"+1,",.01)=DFN 103 .S MDFDA(702,"+1,",.02)=MDD 104 .S MDFDA(702,"+1,",.03)=DUZ 105 .S MDFDA(702,"+1,",.04)=$P(^TMP($J,MDX),U,6) 106 .S MDFDA(702,"+1,",.05)=CONSULT 107 .S MDFDA(702,"+1,",.07)=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";") 108 .S MDFDA(702,"+1,",.09)=0 109 .;Create the new transaction 110 .D UPDATE^DIE("","MDFDA","MDIEN") I '$G(MDIEN(1)) D Q 111 ..S RESULTS(0)="-1^Unable to create CP transaction" 112 . 113 .;Create the new TIU Note 114 .S MDIENS=MDIEN(1)_"," 115 .S MDN=$$NEWTIUN^MDRPCOT(+MDIENS) 116 .S MDNOTE=$S(MDN:$$GET1^DIQ(702,+MDIENS,.06,"I"),1:0) 117 .I 'MDNOTE D Q 118 ..N DA,DIK 119 ..S RESULTS(0)="-1^Unable to create the TIU document" 120 ..S DA=+MDIENS,DIK="^MDD(702," D ^DIK 121 .S RESULTS(0)=MDNOTE 122 Q 123 ; 124 TIUCOMP(MDNOTE) ; [Procedure] Post Signature action to complete transaction 125 ; Input parameters 126 ; 1. MDNOTE [Literal/Required] TIU IEN 127 ; 128 N MDFDA,MDRES 129 S MDRES=$O(^MDD(702,"ATIU",MDNOTE,0)) 130 I $G(^MDD(702,+MDRES,0))="" Q 0 131 I $P($G(^MDD(702,+MDRES,0)),"^",9)=3 Q 1 132 S MDFDA(702,MDRES_",",.09)=3 133 D FILE^DIE("","MDFDA") 134 Q 1 135 ; 136 TIUDEL(MDNOTE) ; [Procedure] TIU Note deletion Update 137 ; Input parameters 138 ; 1. MDNOTE [Literal/Required] TIU IEN 139 ; 140 N MDGBL,MDRES,MDFDA,MDTRAN,RESULTS 141 S MDRES="" F S MDRES=$O(^MDD(702,"ATIU",MDNOTE,MDRES)) Q:'MDRES D 142 .Q:$G(^MDD(702,+MDRES,0))="" 143 .;S MDFDA(702,MDRES_",",.05)="" 144 .S MDFDA(702,MDRES_",",.06)="" 145 .D FILE^DIE("","MDFDA") 146 .S MDTRAN=$O(^MDD(702.001,"ASTUDY",MDRES,MDNOTE,0)) I +MDTRAN N DA,DIK S DA=+MDTRAN,DIK="^MDD(702.001," D ^DIK 147 .D STATUS^MDRPCOT(MDRES_",",2,"TIU note deleted.") 148 .S DATA("TRANSACTION")=MDRES,DATA("PKG")="TIU" 149 .S DATA("MESSAGE")="TIU note deleted." D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA) 150 S MDGBL=$NA(^MDD(702.001,"PK",MDNOTE)) F S MDGBL=$Q(@MDGBL) Q:MDGBL="" Q:$QS(MDGBL,2)'="PK"!($QS(MDGBL,3)'=MDNOTE) S MDTRAN=$QS(MDGBL,6) N DA,DIK S DA=+MDTRAN,DIK="^MDD(702.001," D ^DIK 151 Q 1 152 ; 153 TIUREAS(MDFN,MDOLDC,MDANOTE,MDNDFN,MDNEWC,MDNEWV,MDNTIU) ; [Function] This is an API to clean up and update TIU note re-assignment. 154 ; Input parameters 155 ; 1. MDFN [Literal/Required] The Patient DFN whose TIU document is being re-assigned. 156 ; 2. MDOLDC [Literal/Required] The Consult that the note is being re-assigned from. 157 ; 3. MDANOTE [Literal/Required] The TIU Document IEN that is being re-assigned. 158 ; 4. MDNDFN [Literal/Required] The Patient DFN who will be re-assigned the TIU document. 159 ; 5. MDNEWC [Literal/Required] The consult number that will be assignment the TIU document. 160 ; 6. MDNEWV [Literal/Required] The new visit for the TIU document assignment. 161 ; 7. MDNTIU [Literal/Required] The new reassigned TIU document IEN. 162 ; 163 N MDD,MDGBL,MDTRAN,MDCHK,MDLP,MDMULN,MDN,MDPPR,MDREAS,MDTRANI,MDX 164 I '$G(MDFN) Q "0^No DFN for the TIU note re-assignment." 165 I '$G(MDOLDC) Q "0^No Old Consult # for the note re-assignment." 166 I '$G(MDANOTE) Q "0^No TIU Note IEN." 167 I '$G(MDNDFN) Q "0^No New DFN for the note assignment." 168 I '$G(MDNEWC) Q "0^No New Consult # for the note assignment." 169 I '$G(MDNTIU) Q "0^No New Reassigned TIU IEN." 170 S (MDD,MDCHK,MDREAS,MDTRAN)="",MDPPR=0 K ^TMP("MDTMP",$J) 171 S MDTRAN=$O(^MDD(702,"ATIU",MDANOTE,0)) I +MDTRAN S MDCHK=$G(^MDD(702,MDTRAN,0)),MDTRANI=MDTRAN_"," D 172 .I $P(MDCHK,U,5)=MDOLDC&($P(MDCHK,U,6)=MDANOTE) D 173 ..S MDFDA(702,+MDTRAN_",",.06)="" 174 ..D FILE^DIE("","MDFDA") K MDFDA 175 S MDGBL=$NA(^MDD(702.001,"PK",MDANOTE)) 176 F S MDGBL=$Q(@MDGBL) Q:MDGBL="" Q:$QS(MDGBL,2)'="PK"!($QS(MDGBL,3)'=MDANOTE) S MDN=$QS(MDGBL,6) N DA,DIK S DA=+MDN,DIK="^MDD(702.001," D ^DIK 177 S MDMULN=+$O(^MDD(702.001,"ASTUDY",+MDTRAN,0)) 178 I '+MDMULN I +MDTRAN N DA,DIK S DA=+MDTRAN,DIK="^MDD(702," D ^DIK 179 D NOW^%DTC S MDD=% S MDTRANI=$O(^MDD(702,"ACON",MDNEWC,0)) 180 S MDREAS=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";") 181 I +MDTRANI&(MDNDFN=+$G(^MDD(702,+MDTRANI,0))) D 182 .S MDPPR=$P($G(^MDD(702,+MDTRANI,0)),"^",4) Q:'MDPPR 183 .S MDNEWV=$$GETVSTR^MDRPCOT1(MDNDFN,MDREAS,MDPPR,MDD) 184 .S MDFDA(702,+MDTRANI_",",.06)=MDNTIU 185 .S MDFDA(702,"+1,",.07)=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";") 186 .D FILE^DIE("","MDFDA") K MDFDA 187 I 'MDPPR D 188 .D CPLIST^GMRCCP(MDNDFN,,$NA(^TMP("MDTMP",$J))) 189 .S MDX="" 190 .F S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX S:$P(^(MDX),U,5)=MDNEWC MDPPR=$P(^(MDX),U,6) 191 K ^TMP("MDTMP",$J) 192 I +MDPPR Q 1 193 S MDNEWV=$$GETVSTR^MDRPCOT1(MDNDFN,MDREAS,MDPPR,MDD) 194 S MDFDA(702,"+1,",.01)=MDNDFN 195 S MDFDA(702,"+1,",.02)=MDD 196 S MDFDA(702,"+1,",.03)=DUZ 197 S MDFDA(702,"+1,",.04)=MDPPR 198 S MDFDA(702,"+1,",.05)=MDNEWC 199 S MDFDA(702,"+1,",.06)=MDNTIU 200 S MDFDA(702,"+1,",.07)=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";") 201 S MDFDA(702,"+1,",.09)=0 202 D UPDATE^DIE("","MDFDA") 203 Q 1 204 ; 205 TRANS(STR) ; [Function] Translate the upper arrows to blanks 206 ; Input parameters 207 ; 1. STR [Literal/Required] Input: Text with upper arrows that needs to be removed 208 ; 209 I STR["^" Q $TR(STR,"^"," ") 210 Q STR 211 ; 212 GETCP(RESULTS,MDCSLT) ; API to return CP Study data 213 ; Input Parameters: 214 ; 1. RESULTS [Literal/Required] Return Array 215 ; 2. MDCSLT [Literal/Required] Consult number 216 ; 217 ; Output: 218 ; RESULTS(0)=-1^Error Message or 1 for success 219 ; (N,1)=CP Study Number 220 ; (N,2)=Patient DFN 221 ; (N,3)=Created Date/Time 222 ; (N,4)=Created By 223 ; (N,5)=CP Definition (External Name) 224 ; (N,6)=Consult Number 225 ; (N,7)=TIU Note IEN 226 ; (N,8)=VSTR 227 ; (N,9)=Transaction Status 228 ; 229 ; Where N = 1..n entries 230 ; 231 N MDCT,MDX,MDY 232 I '$G(MDCSLT) S @RESULTS@(0)="-1^No Consult Number passed" Q 233 S MDX=$O(^MDD(702,"ACON",MDCSLT,0)) I 'MDX S @RESULTS@(0)="-1^No CP Study Entry." Q 234 S @RESULTS@(0)=1 235 S MDCT=0,MDX="" F S MDX=$O(^MDD(702,"ACON",MDCSLT,MDX)) Q:MDX<1 D 236 .S MDCT=MDCT+1,@RESULTS@(MDCT,1)=MDX 237 .S MDY=$G(^MDD(702,+MDX,0)),@RESULTS@(MDCT,2)=$P(MDY,U),@RESULTS@(MDCT,3)=$P(MDY,U,2),@RESULTS@(MDCT,4)=$P(MDY,U,3),@RESULTS@(MDCT,5)=$$GET1^DIQ(702,+MDX,.04,"E") 238 .S @RESULTS@(MDCT,6)=$P(MDY,U,5),@RESULTS@(MDCT,7)=$P(MDY,U,6),@RESULTS@(MDCT,8)=$P(MDY,U,7),@RESULTS@(MDCT,9)=$$GET1^DIQ(702,+MDX,.09,"E") 239 Q 1 MDAPI ; HOIFO/DP/NCA - CP API Calls ; [05-05-2003 10:28] 2 ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004 3 ; Description: 4 ; These API's are for use by external packages communicating with CP. 5 ; 6 ; Integration Agreements: 7 ; IA# 3378 [Restricted] Documents the APIs that external packages use to communicate with CP. 8 ; IA# 3468 [Subscription] Use GMRCCP APIs. 9 ; 10 EXTDATA(MDPROC) ; [Procedure] 11 ; Returns 0/1 for external data needed 12 ; Called by Consults to determine status of consult ordered 13 ; 14 ; Input parameters 15 ; 1. MDPROC [Literal/Required] CP Definition IEN 16 ; 17 Q:'$D(^MDS(702.01,+$G(MDPROC),0)) 0 18 I +$P(^MDS(702.01,+$G(MDPROC),0),U,3)!($O(^(.1,0))) Q 1 19 E Q 0 20 ; 21 ISTAT(MDARR) ; [Procedure] Called by Imaging to update status 22 ; Input parameters 23 ; 1. MDARR [Literal/Required] Array from Imaging 24 ; 25 ; Input: MDARR(0)="0^error message" or "1^success message" 26 ; MDARR(1)=TrackID (CP;Transaction IEN) 27 ; MDARR(2)=Queue Number 28 ; MDARR(3..N)=Warnings 29 N MDCON,MDCR,MDIEN,MDIENS,MDLP,MDSTAT,MDSTR,MDTIU,RESULTS 30 Q:$G(MDARR(0))="" 31 Q:$G(MDARR(1))="" 32 Q:$P(MDARR(1),";")'="CP" 33 Q:'(+$P(MDARR(1),";",2)) 34 S MDIEN=+$P(MDARR(1),";",2),MDIENS=MDIEN_"," 35 S MDSTAT=+$P(MDARR(0),"^") 36 S DATA("TRANSACTION")=MDIEN 37 ; Is it in error? 38 I 'MDSTAT D Q 39 .D STATUS^MDRPCOT(MDIENS,2,$P(MDARR(0),"^",2)) 40 .S DATA("PKG")="IMAGING" 41 .S DATA("MESSAGE")=$P(MDARR(0),"^",2) D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA) 42 .F MDLP=2:0 S MDLP=$O(MDARR(MDLP)) Q:'MDLP I $G(MDARR(MDLP))'="" D 43 ..S DATA("MESSAGE")=$$TRANS(MDARR(MDLP)) D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA) 44 .D IMGSTAT^MDRPCOT1(+MDIENS,2) Q 45 ; Call Consults that Partial Result ready 46 S MDCON=+$P(^MDD(702,MDIEN,0),"^",5),MDTIU=+$P(^(0),"^",6) 47 S MDCR=$$UPDCONS^MDRPCOT1(MDCON,MDTIU) 48 I +MDCR<0 D Q 49 .D STATUS^MDRPCOT(MDIENS,2,$P(MDCR,"^",2)) 50 .S DATA("PKG")="CONSULTS",DATA("MESSAGE")=$P(MDCR,"^",2) 51 .D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA) 52 .Q 53 ; Closeout the record 54 D STATUS^MDRPCOT(MDIENS,3,"") 55 ; Update Images Status 56 D IMGSTAT^MDRPCOT1(+MDIENS,3) 57 Q 58 ; 59 ITIU(RESULTS,DFN,CONSULT,VSTRING) ; [Procedure] API for Vista Imaging 60 ; This API enables VistA Imaging to retrieve/create a TIU note for 61 ; a consult for attaching images to. 62 ; 63 ; RESULTS(0) will equal one of the following 64 ; IEN of the TIU note if successful 65 ; or on failure one of the following status messages 66 ; -1^No patient DFN 67 ; -1^No Consult IEN 68 ; -1^No VString 69 ; -1^Error in CP transaction 70 ; -1^Unable to create CP transaction 71 ; -1^Unable to create the TIU document 72 ; -1^No such consult for this patient. 73 ; 74 ; Input parameters 75 ; 1. RESULTS [Reference/Required] Return array 76 ; 2. DFN [Literal/Required] Patient IEN 77 ; 3. CONSULT [Literal/Required] Consult IEN 78 ; 4. VSTRING [Literal/Optional] VString data for TIU Note (Required to create new TIU note) 79 ; 80 ; Variables: 81 ; MDIEN: [Private] Returns IEN from UPDATE~DIE call 82 ; MDIENS: [Private] Scratch 83 ; MDNOTE: [Private] Scratch 84 ; MDTRANS: [Private] Contains IEN of CP transaction 85 ; 86 ; New private variables 87 NEW MDIEN,MDIENS,MDNOTE,MDTRANS 88 K ^TMP($J),^TMP("MDTIUST",$J) 89 N MDD,MDN,MDTIUER,MDTST,MDNEWV,MDTIUD S (MDTIUD,MDTIUER,MDTST)="" 90 I '$G(DFN) S RESULTS(0)="-1^No patient DFN" Q 91 I '$G(CONSULT) S RESULTS(0)="-1^No Consult IEN" Q 92 ; Look for existing transaction 93 S MDTIUD=$$PREV^MDRPCOT(+CONSULT,"") 94 I +MDTIUD S RESULTS(0)=+MDTIUD Q 95 ; No transaction, must create one for this consult 96 I $G(VSTRING)="" S RESULTS(0)="-1^No VString" Q 97 D CPLIST^GMRCCP(DFN,,$NA(^TMP($J))) 98 S MDX="" F S MDX=$O(^TMP($J,MDX)) Q:'MDX I $P(^(MDX),U,5)=CONSULT D Q 99 .D NOW^%DTC S MDD=% 100 .S:$L(VSTRING,";")=1 VSTRING=";"_VSTRING 101 .S MDNEWV=$$GETVSTR^MDRPCOT1(DFN,VSTRING,$P(^TMP($J,MDX),U,6),MDD) 102 .S MDFDA(702,"+1,",.01)=DFN 103 .S MDFDA(702,"+1,",.02)=MDD 104 .S MDFDA(702,"+1,",.03)=DUZ 105 .S MDFDA(702,"+1,",.04)=$P(^TMP($J,MDX),U,6) 106 .S MDFDA(702,"+1,",.05)=CONSULT 107 .S MDFDA(702,"+1,",.07)=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";") 108 .S MDFDA(702,"+1,",.09)=0 109 .;Create the new transaction 110 .D UPDATE^DIE("","MDFDA","MDIEN") I '$G(MDIEN(1)) D Q 111 ..S RESULTS(0)="-1^Unable to create CP transaction" 112 . 113 .;Create the new TIU Note 114 .S MDIENS=MDIEN(1)_"," 115 .S MDN=$$NEWTIUN^MDRPCOT(+MDIENS) 116 .S MDNOTE=$S(MDN:$$GET1^DIQ(702,+MDIENS,.06,"I"),1:0) 117 .I 'MDNOTE D Q 118 ..N DA,DIK 119 ..S RESULTS(0)="-1^Unable to create the TIU document" 120 ..S DA=+MDIENS,DIK="^MDD(702," D ^DIK 121 .S RESULTS(0)=MDNOTE 122 Q 123 ; 124 TIUCOMP(MDNOTE) ; [Procedure] Post Signature action to complete transaction 125 ; Input parameters 126 ; 1. MDNOTE [Literal/Required] TIU IEN 127 ; 128 N MDFDA,MDRES 129 S MDRES=$O(^MDD(702,"ATIU",MDNOTE,0)) 130 I $G(^MDD(702,+MDRES,0))="" Q 0 131 I $P($G(^MDD(702,+MDRES,0)),"^",9)=3 Q 1 132 S MDFDA(702,MDRES_",",.09)=3 133 D FILE^DIE("","MDFDA") 134 Q 1 135 ; 136 TIUDEL(MDNOTE) ; [Procedure] TIU Note deletion Update 137 ; Input parameters 138 ; 1. MDNOTE [Literal/Required] TIU IEN 139 ; 140 N MDRES,MDFDA,RESULTS 141 S MDRES="" F S MDRES=$O(^MDD(702,"ATIU",MDNOTE,MDRES)) Q:'MDRES D 142 .Q:$G(^MDD(702,+MDRES,0))="" 143 .S MDFDA(702,MDRES_",",.05)="" 144 .S MDFDA(702,MDRES_",",.06)="" 145 .D FILE^DIE("","MDFDA") 146 .D STATUS^MDRPCOT(MDRES_",",2,"TIU note deleted.") 147 .S DATA("TRANSACTION")=MDRES,DATA("PKG")="TIU" 148 .S DATA("MESSAGE")="TIU note deleted." D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA) 149 Q 1 150 ; 151 TIUREAS(MDFN,MDOLDC,MDANOTE,MDNDFN,MDNEWC,MDNEWV,MDNTIU) ; [Function] This is an API to clean up and update TIU note re-assignment. 152 ; Input parameters 153 ; 1. MDFN [Literal/Required] The Patient DFN whose TIU document is being re-assigned. 154 ; 2. MDOLDC [Literal/Required] The Consult that the note is being re-assigned from. 155 ; 3. MDANOTE [Literal/Required] The TIU Document IEN that is being re-assigned. 156 ; 4. MDNDFN [Literal/Required] The Patient DFN who will be re-assigned the TIU document. 157 ; 5. MDNEWC [Literal/Required] The consult number that will be assignment the TIU document. 158 ; 6. MDNEWV [Literal/Required] The new visit for the TIU document assignment. 159 ; 7. MDNTIU [Literal/Required] The new reassigned TIU document IEN. 160 ; 161 N MDD,MDTRAN,MDCHK,MDLP,MDPPR,MDREAS,MDTRANI,MDX 162 I '$G(MDFN) Q "0^No DFN for the TIU note re-assignment." 163 I '$G(MDOLDC) Q "0^No Old Consult # for the note re-assignment." 164 I '$G(MDANOTE) Q "0^No TIU Note IEN." 165 I '$G(MDNDFN) Q "0^No New DFN for the note assignment." 166 I '$G(MDNEWC) Q "0^No New Consult # for the note assignment." 167 I '$G(MDNTIU) Q "0^No New Reassigned TIU IEN." 168 S (MDD,MDCHK,MDREAS,MDTRAN)="",MDPPR=0 K ^TMP("MDTMP",$J) 169 F S MDTRAN=$O(^MDD(702,"ACON",MDOLDC,MDTRAN)) Q:'MDTRAN D 170 .S MDCHK=$G(^MDD(702,MDTRAN,0)),MDTRANI=MDTRAN_"," 171 .I $P(MDCHK,U,5)=MDOLDC&($P(MDCHK,U,6)=MDANOTE) D 172 ..S:'MDPPR MDPPR=$P(MDCHK,U,4) 173 ..N DA,DIK S DA=+MDTRAN,DIK="^MDD(702," D ^DIK 174 I 'MDPPR D 175 .D CPLIST^GMRCCP(MDNDFN,,$NA(^TMP("MDTMP",$J))) 176 .S MDX="" 177 .F S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX S:$P(^(MDX),U,5)=MDNEWC MDPPR=$P(^(MDX),U,6) 178 K ^TMP("MDTMP",$J) 179 I 'MDPPR Q 1 180 D NOW^%DTC S MDD=% 181 S MDREAS=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";") 182 S MDNEWV=$$GETVSTR^MDRPCOT1(MDNDFN,MDREAS,MDPPR,MDD) 183 S MDFDA(702,"+1,",.01)=MDNDFN 184 S MDFDA(702,"+1,",.02)=MDD 185 S MDFDA(702,"+1,",.03)=DUZ 186 S MDFDA(702,"+1,",.04)=MDPPR 187 S MDFDA(702,"+1,",.05)=MDNEWC 188 S MDFDA(702,"+1,",.06)=MDNTIU 189 S MDFDA(702,"+1,",.07)=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";") 190 S MDFDA(702,"+1,",.09)=0 191 D UPDATE^DIE("","MDFDA","MDTRANI") Q:'$G(MDTRANI(1)) 1 192 Q 1 193 ; 194 TRANS(STR) ; [Function] Translate the upper arrows to blanks 195 ; Input parameters 196 ; 1. STR [Literal/Required] Input: Text with upper arrows that needs to be removed 197 ; 198 I STR["^" Q $TR(STR,"^"," ") 199 Q STR 200 ; -
WorldVistAEHR/trunk/r/CLINICAL_PROCEDURES-MD/MDHL7A.m
r613 r623 1 MDHL7A ; HOIFO/WAA - Routine to Decode HL7 for CP ;9/17/07 08:17 2 ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102 3 ; Reference DBIA #10035 [Supported] for DPT calls. 4 ; Reference DBIA #10106 [Supported] for HLFNC calls. 5 ; Reference DBIA #10062 [Supported] for VADPT6 calls. 6 ; Reference DBIA #2701 [Supported] for MPIF001 calls 7 ; Reference DBIA #10096 [Supported] for ^%ZOSF calls 8 EN ; [Procedure] Entry Point for Message Array in MSG 9 N %,BID,CODE,CPT,DA,DATE,DFN,DIK,DLCO,DTO,DZ,ERRTX,EXAM,EXE,MDFLAG,FIL 10 N I,ICNT,ID,IMP,J,K,LBL,LINO,LINE,LN,MDAPP,MDRTN,MG,MSG,N,NAM,NEXT,NUM 11 N ORIFN,P,PID,PIEN,S,SEG,SET,SEP,MDSSN,STR,STYP,SUB,TCNT,TXT,UNIQ,SEC 12 N UNITS,VA,VAL,X,XMBODY,XMDUZ,XMSUBJ,XMTO,Z,ZZ,Z1,Z2,MDERROR 13 N ECODE,MDIEN,MDOBX,NUMZ,PNAM,ZCODE,MDDEV,MDD702,DEVNAME,DEVIEN,MDQFLG 14 N MDIORD 15 K ^TMP($J,"MDHL7A"),^TMP($J,"MDHL7"),^TMP($J,"MDHL7A1") 16 S MDFLAG=0,MDERROR=0,MDQFLG=0 17 Q:$G(HLMTIENS)="" 18 S ^TMP($J,"MDHL7A1")="" 19 S HLREST="^TMP($J,""MDHL7A1"")" 20 S X=$$MSGIEN^MDHL7U3(HLMTIENS,HLREST) ; This code is to convert the HL7 Message **6** 21 I $P(X,U)=0 D Q 22 . S DEVIEN=0,ECODE=0 23 . S ERRTX=$P(X,U,2) 24 . D ^MDHL7X 25 . Q 26 I $P(X,U)=1 D XVERT^MDHL7U3("MDHL7A1","MDHL7A") 27 K HLNODE,^TMP($J,"MDHL7A1") 28 ; 29 EN2 ; [Procedure] No Description 30 S (DEVIEN,DEVNAME)="",I=0 31 F I=1:1 S X=$G(^TMP($J,"MDHL7A",I)) Q:X="" Q:$E(X,1,3)="OBX" D 32 . S:$E(X,1,3)="MSH" DEVNAME=$P(X,"|",4) 33 . I DEVNAME="",HLREC("SFN")'="" S DEVNAME=HLREC("SFN") 34 . I $E(X,1,3)="MSH",DEVNAME'="Instrument Manager" S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0)) 35 . I $E(X,1,3)="OBR" D 36 .. I DEVNAME="Instrument Manager" D 37 ... S DEVNAME=$P(X,"|",25) 38 ... Q 39 .. S MDIORD=$P(X,"|",4) 40 .. S MDD702=$S(+MDIORD<1:"",1:$$GETSTDY^MDRPCOT1(MDIORD)) 41 .. I MDD702<1 S MDD702="" Q 42 .. I MDD702>0 D ;Validate the entry from 702 is good. 43 ... I $G(^MDD(702,MDD702,0))="" S MDD702="" Q 44 ... S DEVIEN=$$GET1^DIQ(702,MDD702,.11,"I") 45 ... I DEVIEN<1 S DEVIEN="" ; No device defined 46 ... Q 47 .. Q 48 . Q 49 I DEVIEN="",DEVNAME'="" S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0)) 50 I DEVNAME="" S ERRTX="Invalid device Code" D ^MDHL7X Q 51 I DEVIEN="" S ERRTX="Invalid device entry" D ^MDHL7X Q 52 S ZCODE=$P($G(^MDS(702.09,DEVIEN,.1)),"^",2) 53 S ECODE=0,INST=DEVIEN,MDAPP=DEVNAME 54 I 'INST S ERRTX="Invalid Application Code" D ^MDHL7X Q 55 D INST^MDHL7U2(DEVIEN,.ECODE) I 'ECODE D Q 56 . S ERRTX="Device Error" D ^MDHL7X 57 . Q 58 I (ZCODE="M")!(ZCODE="B") D Q:MDERROR Q:ZCODE="M" ; 59 . S MDFLAG=1,MDERROR=0 ; Tell Medicine that CP is talking to HL7 60 . D ^MDHL7MCA ; Run the Medicine routines 61 . Q:MDERROR ; Medicine found an error and sent an error back 62 . Q 63 S NUMZ=$O(^TMP($J,"MDHL7A",""),-1) 64 S NUM=0,MDOBX=0 65 F NUM=1:1:NUMZ D Q:$G(ERRTX)'="" 66 . S LINO=^TMP($J,"MDHL7A",NUM) 67 . S SEC=$P(LINO,"|") 68 . I SEC="MSH" D MSH Q 69 . I SEC="PID" D PID Q 70 . I SEC="OBR" D OBR Q 71 . I SEC="PV1" Q 72 . I SEC="ORC" Q 73 . I SEC="OBX" S MDOBX=1 Q 74 . Q 75 Q:$G(ERRTX)'="" 76 I 'MDOBX S ERRTX="OBX not found when expected" D ^MDHL7X Q 77 D OBX 78 D STATUS(MDIEN,"P") 79 K ^TMP($J,"MDHL7A"),^TMP($J,"MDHL7") 80 Q 81 STATUS(DA,STAT) ; Update the status of the report in 703.1 82 Q:$G(ERRTX)'="" 83 S $P(^MDD(703.1,DA,0),U,9)=STAT 84 S DIK="^MDD(703.1," D IX1^DIK 85 Q 86 IM ;Instrument Manager Interface 87 Q:DEVNAME'="Instrument Manager" 88 I $E(X,1,3)'="OBR" Q 89 S DEVNAME=$P(X,"|",25) 90 S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0)) 91 Q 92 ; 93 MSH ; [Procedure] Decode MSH 94 N SEG 95 I '$D(^TMP($J,"MDHL7A",NUM)) Q 96 S X=$G(^TMP($J,"MDHL7A",NUM)),SEG("MSH")=X 97 I $E(X,1,3)'="MSH" S ERRTX="MSH not first record" D ^MDHL7X Q 98 Q 99 ; 100 OBR ; [Procedure] Check OBR 101 N MDGMRC 102 S X=$G(^TMP($J,"MDHL7A",NUM)) I $E(X,1,3)'="OBR" S ERRTX="OBR not found when expected" D ^MDHL7X Q 103 S SEG("OBR")=X 104 S MDIORD=$P(X,"|",4) 105 S MDD702=$S(+MDIORD<1:"",1:$$GETSTDY^MDRPCOT1(MDIORD)) 106 ;I MDD702'="" S MDD702=$$CHK^MDNCHK(MDD702) ; PATCH 11 107 S ORIFN=$P(X,"|",3),(EXAM,%)=$P(X,"|",5) I EXAM'="" S EXAM=$P(%,"^",2) I EXAM="" S EXAM=$P(%,"^",1) 108 S CPT=$P(X,"|",5) I $P(CPT,"^",3)["CPT" S CPT=$P(CPT,"^",1) 109 S DTO="",DATE=$P(X,"|",8) I DATE'="" S:$L(DATE)>14 DATE=$E(DATE,1,14) S DTO=$$FMDATE^HLFNC(DATE) 110 ; vvv== Added to address the issues of mismatch 111 I $G(MDD702)>0 I DFN'=$$GET1^DIQ(702,MDD702,.01,"I") S ERRTX="Patient name Mismatch. Name in PID doesn't match the name in the CP Order #"_MDD702_"." D ^MDHL7X Q 112 I $G(MDD702)>0 I MDDOB'=$$GET1^DIQ(2,DFN,.03,"I") S ERRTX="Patient DOB Mismatch. DOB in PID doesn't match the DOB in the CP Order #"_MDD702_"." D ^MDHL7X Q 113 I DTO="" S ERRTX="Missing required Date/Time of Procedure in OBR" D ^MDHL7X Q 114 ;;S UNIQ=$TR($H,",","-") 115 S UNIQ=$$NEWID(DFN,DATE,INST,$G(MDD702),HLMTIEN) 116 I +UNIQ="-1" S ERRTX="Unable to Create or Lock 703.1" D ^MDHL7X Q 117 S MDIEN=$P(UNIQ,"^",1) ; Got the IEN for 703.1 118 N SET S SET=DTO_"^"_$P(UNIQ,U,2),ICNT=0 N IMP 119 S MDRTN=$P($G(^MDS(702.09,INST,.1)),"^",1) S:MDRTN'["^" MDRTN="^"_MDRTN 120 S X=MDRTN S:X["^" X=$P(X,"^",2) X ^%ZOSF("TEST") I '$T S ERRTX="Processing routine not found" D ^MDHL7X Q ; IA %10096 121 D CPTICD^MDHL7U3(X,MDIEN) ; Update CPT and ICD9 122 D PHY^MDHL7U3(X,MDIEN) ; Get Doc who did the procedure. 123 Q 124 ; 125 PID ; [Procedure] Check PID 126 S X=$G(^TMP($J,"MDHL7A",NUM)) I $E(X,1,3)'="PID" S ERRTX="PID not second record" D ^MDHL7X Q 127 S SEG("PID")=X 128 S MDDOB=$P(X,"|",8) I MDDOB'="" S MDDOB=($E(MDDOB,1,4)-1700)_$E(MDDOB,5,8) 129 I $L($P(X,"|",4))'<16 D I +DFN=-1 Q 130 . N ICN 131 . S ICN=$P(X,"|",4) 132 . S DFN=$$GETDFN^MPIF001(ICN) 133 . I +DFN=-1 S ERRTX=$P(DFN,U,2) 134 . D MDSSN I DFN<1 S ERRTX="SSN not found" D ^MDHL7X Q 135 . I DFN>0 K ERRTX 136 . S MDSSN=$$GET1^DIQ(2,DFN,.09,"I") I MDSSN="" S MDSSN=" ",DFN=0 137 . Q 138 E D MDSSN 139 I 'DFN S ERRTX="SSN not found" D ^MDHL7X Q 140 S Z1=$P($G(^DPT(DFN,0)),",",1),Z2=$P(NAM,"^",1) 141 S Z1=$TR(Z1,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 142 S Z2=$TR(Z2,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 143 I $E(Z1,1,3)'=$E(Z2,1,3) S ERRTX="Last Name MisMatch" D ^MDHL7X Q 144 S PNAM=$TR(NAM,"^",",") 145 D PID^VADPT6 S PID=$G(VA("PID")),BID=$G(VA("BID")) N VA 146 Q 147 MDSSN ; This subroutine is to match up the SSN for a patient. 148 S NAM=$P(X,"|",6),MDSSN=$P(X,"|",20) I $L(MDSSN)<9 S MDSSN=$P(X,"|",4) 149 S MDSSN=$P(MDSSN,"^",1) I MDSSN'?9N S MDSSN=$TR(MDSSN,"- ","") 150 I $E(MDSSN,$L(MDSSN))="P" S MDSSN=$E(MDSSN,1,9) 151 S:MDSSN'?9N MDSSN=" " S DFN=$O(^DPT("SSN",MDSSN,0)) 152 I 'DFN S DFN=$O(^DPT("SSN",MDSSN_"P",0)) 153 Q 154 ; 155 OBX ; [Observation] 156 D @MDRTN 157 Q 158 NEWID(DFN,DATE,INST,MDD702,HLMTIEN) ; Generate a new entry and ID of 703.1 159 N NEWID,MDFDA,MDIEN,MDNO 160 S NEWID=$TR($H,",","-") ; Create inital ID 161 L +(^MDD(703.1,"B")):60 E Q "-1" 162 ;^^--- Unable to get a lock in the file 163 F Q:'$D(^MDD(703.1,"B",NEWID)) H 1 S NEWID=$TR($H,",","-") 164 ;^^--- Search to create a new ID if current ID is in use 165 S MDFDA(703.1,"+1,",.01)=NEWID 166 S MDFDA(703.1,"+1,",.02)=DFN 167 S MDFDA(703.1,"+1,",.03)=$$HL7TFM^MDHL7U(DATE) 168 S MDFDA(703.1,"+1,",.04)=INST 169 S MDFDA(703.1,"+1,",.05)=MDD702 170 S MDFDA(703.1,"+1,",.06)=HLMTIEN 171 D UPDATE^DIE("","MDFDA","MDIEN") 172 L -(^MDD(703.1,"B")) 173 I $G(MDIEN(1))>0 D Q MDIEN(1)_U_NEWID 174 . S ^MDD(703.1,MDIEN(1),.1,0)="^703.11S^0^0" 175 . S MDNO=$$NTIU^MDRPCW1(+MDD702) 176 . Q 177 ; ^^--- Create Subfile and quit 178 Q "-1" ; Unable to create file 179 ; 180 PROC ; [Procedure] Create report entry in file (703.1) 181 D PROC^MDHL7U 182 Q 1 MDHL7A ; HOIFO/WAA - Routine to Decode HL7 for CP ; [05-07-2001 10:38] 2 ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004 3 ; Reference DBIA #10035 [Supported] for DPT calls. 4 ; Reference DBIA #10106 [Supported] for HLFNC calls. 5 ; Reference DBIA #10062 [Supported] for VADPT6 calls. 6 ; Reference DBIA #2701 [Supported] for MPIF001 Calls 7 EN ; [Procedure] Entry Point for Message Array in MSG 8 N %,BID,CODE,CPT,DA,DATE,DFN,DIK,DLCO,DTO,DZ,ERRTX,EXAM,EXE,MDFLAG,FIL 9 N I,ICNT,ID,IMP,J,K,LBL,LINO,LINE,LN,MDAPP,MDRTN,MG,MSG,N,NAM,NEXT,NUM 10 N ORIFN,P,PID,PIEN,S,SEG,SET,SEP,MDSSN,STR,STYP,SUB,TCNT,TXT,UNIQ,SEC 11 N UNITS,VA,VAL,X,XMBODY,XMDUZ,XMSUBJ,XMTO,Z,ZZ,Z1,Z2,MDERROR 12 N ECODE,MDIEN,MDOBX,NUMZ,PNAM,ZCODE,MDDEV,MDD702,DEVNAME,DEVIEN,MDQFLG 13 N MDIORD 14 K ^TMP($J,"MDHL7A"),^TMP($J,"MDHL7") 15 S MDFLAG=0,MDERROR=0,MDQFLG=0 16 F I=1:1 X HLNEXT Q:MDQFLG S ^TMP($J,"MDHL7A",I)=$TR(HLNODE,$C(10),""),J=0 S:HLQUIT<1 MDQFLG=1 F S J=$O(HLNODE(J)) Q:J<1 S ^TMP($J,"MDHL7A",I,J)=$TR(HLNODE(J),$C(10),"") 17 K HLNODE 18 ; 19 EN2 ; [Procedure] No Description 20 S (DEVIEN,DEVNAME)="" 21 F I=1:1 S X=$G(^TMP($J,"MDHL7A",I)) Q:X="" Q:$E(X,1,3)="OBX" D 22 . S:$E(X,1,3)="MSH" DEVNAME=$P(X,"|",4) 23 . I $E(X,1,3)="MSH",DEVNAME'="Instrument Manager" S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0)) 24 . I $E(X,1,3)="OBR" D 25 .. I DEVNAME="Instrument Manager" D 26 ... S DEVNAME=$P(X,"|",25) 27 ... Q 28 .. S MDIORD=$P(X,"|",4) 29 .. S MDD702=$S(+MDIORD<1:"",1:$$GETSTDY^MDRPCOT1(MDIORD)) 30 .. I MDD702<1 S MDD702="" Q 31 .. I MDD702>0 D ;Validate the entry from 702 is good. 32 ... I $G(^MDD(702,MDD702,0))="" S MDD702="" Q 33 ... S DEVIEN=$$GET1^DIQ(702,MDD702,.11,"I") 34 ... I DEVIEN<1 S DEVIEN="" ; No device defined 35 ... Q 36 .. Q 37 . Q 38 I DEVIEN="",DEVNAME'="" S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0)) 39 I DEVNAME="" S ERRTX="Invalid device Code" D ^MDHL7X Q 40 I DEVIEN="" S ERRTX="Invalid device entry" D ^MDHL7X Q 41 S ZCODE=$P($G(^MDS(702.09,DEVIEN,.1)),"^",2) 42 S ECODE=0,INST=DEVIEN,MDAPP=DEVNAME 43 I 'INST S ERRTX="Invalid Application Code" D ^MDHL7X Q 44 D INST^MDHL7U2(DEVIEN,.ECODE) I 'ECODE D Q 45 . S ERRTX="Device Error" D ^MDHL7X 46 . Q 47 I (ZCODE="M")!(ZCODE="B") D Q:MDERROR Q:ZCODE="M" ; 48 . S MDFLAG=1,MDERROR=0 ; Tell Medicine that CP is talking to HL7 49 . ;S MSG(1)=^TMP($J,"MDHL7A",1) 50 . ;S MSG(2)=^TMP($J,"MDHL7A",2) 51 . D ^MDHL7MCA ; Run the Medicine routines 52 . Q:MDERROR ; Medicine found an error and sent an error back 53 . ;;I ZCODE="M" D GENACK^MDHL7X 54 . Q 55 S NUMZ=$O(^TMP($J,"MDHL7A",""),-1) 56 S NUM=0,MDOBX=0 57 F NUM=1:1:NUMZ D Q:$G(ERRTX)'="" 58 . S LINO=^TMP($J,"MDHL7A",NUM) 59 . S SEC=$P(LINO,"|") 60 . I SEC="MSH" D MSH Q 61 . I SEC="PID" D PID Q 62 . I SEC="OBR" D OBR Q 63 . I SEC="PV1" Q 64 . I SEC="ORC" Q 65 . I SEC="OBX" S MDOBX=1 Q 66 . Q 67 Q:$G(ERRTX)'="" 68 I 'MDOBX S ERRTX="OBX not found when expected" D ^MDHL7X Q 69 D OBX 70 D STATUS(MDIEN,"P") 71 K ^TMP($J,"MDHL7A"),^TMP($J,"MDHL7") 72 Q 73 STATUS(DA,STAT) ; Update the status of the report in 703.1 74 Q:$G(ERRTX)'="" 75 S $P(^MDD(703.1,DA,0),U,9)=STAT 76 S DIK="^MDD(703.1," D IX1^DIK 77 Q 78 IM ;Instrument Manager Interface 79 Q:DEVNAME'="Instrument Manager" 80 I $E(X,1,3)'="OBR" Q 81 S DEVNAME=$P(X,"|",25) 82 S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0)) 83 Q 84 ; 85 MSH ; [Procedure] Decode MSH 86 N SEG 87 I '$D(^TMP($J,"MDHL7A",NUM)) Q 88 S X=$G(^TMP($J,"MDHL7A",NUM)),SEG("MSH")=X 89 I $E(X,1,3)'="MSH" S ERRTX="MSH not first record" D ^MDHL7X Q 90 Q 91 ; 92 OBR ; [Procedure] Check OBR 93 N MDGMRC 94 S X=$G(^TMP($J,"MDHL7A",NUM)) I $E(X,1,3)'="OBR" S ERRTX="OBR not found when expected" D ^MDHL7X Q 95 S SEG("OBR")=X 96 S MDIORD=$P(X,"|",4) 97 S MDD702=$S(+MDIORD<1:"",1:$$GETSTDY^MDRPCOT1(MDIORD)) 98 S ORIFN=$P(X,"|",3),(EXAM,%)=$P(X,"|",5) I EXAM'="" S EXAM=$P(%,"^",2) I EXAM="" S EXAM=$P(%,"^",1) 99 S CPT=$P(X,"|",5) I $P(CPT,"^",3)["CPT" S CPT=$P(CPT,"^",1) 100 S DTO="",DATE=$P(X,"|",8) I DATE'="" S:$L(DATE)>14 DATE=$E(DATE,1,14) S DTO=$$FMDATE^HLFNC(DATE) 101 ; vvv== Added to address the issues of mismatch 102 I $G(MDD702)>0 I DFN'=$$GET1^DIQ(702,MDD702,.01,"I") S ERRTX="Patient name Mismatch. Name in PID doesn't match the name in the CP Order #"_MDD702_"." D ^MDHL7X Q 103 I DTO="" S ERRTX="Missing required Date/Time of Procedure in OBR" D ^MDHL7X Q 104 ;;S UNIQ=$TR($H,",","-") 105 S UNIQ=$$NEWID(DFN,DATE,INST,$G(MDD702),HLMTIEN) 106 I +UNIQ="-1" S ERRTX="Unable to Create or Lock 703.1" D ^MDHL7X Q 107 S MDIEN=$P(UNIQ,"^",1) ; Got the IEN for 703.1 108 N SET S SET=DTO_"^"_$P(UNIQ,U,2),ICNT=0 N IMP 109 S MDRTN=$P($G(^MDS(702.09,INST,.1)),"^",1) S:MDRTN'["^" MDRTN="^"_MDRTN 110 S X=MDRTN S:X["^" X=$P(X,"^",2) X ^%ZOSF("TEST") I '$T S ERRTX="Processing routine not found" D ^MDHL7X Q ; IA %10096 111 Q 112 ; 113 PID ; [Procedure] Check PID 114 S X=$G(^TMP($J,"MDHL7A",NUM)) I $E(X,1,3)'="PID" S ERRTX="PID not second record" D ^MDHL7X Q 115 S SEG("PID")=X 116 I $L($P(X,"|",4))'<16 D I +DFN=-1 Q 117 . N ICN 118 . S ICN=$P(X,"|",4) 119 . S DFN=$$GETDFN^MPIF001(ICN) 120 . I +DFN=-1 S ERRTX=$P(DFN,U,2) 121 . D MDSSN I DFN<1 S ERRTX="SSN not found" D ^MDHL7X Q 122 . I DFN>0 K ERRTX 123 . S MDSSN=$$GET1^DIQ(2,DFN,.09,"I") I MDSSN="" S MDSSN=" ",DFN=0 124 . Q 125 E D MDSSN 126 I 'DFN S ERRTX="SSN not found" D ^MDHL7X Q 127 S Z1=$P($G(^DPT(DFN,0)),",",1),Z2=$P(NAM,"^",1) 128 S Z1=$TR(Z1,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 129 S Z2=$TR(Z2,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 130 I $E(Z1,1,3)'=$E(Z2,1,3) S ERRTX="Last Name MisMatch" D ^MDHL7X Q 131 S PNAM=$TR(NAM,"^",",") 132 D PID^VADPT6 S PID=$G(VA("PID")),BID=$G(VA("BID")) N VA 133 Q 134 MDSSN ; This subroutine is to match up the SSN for a patient. 135 S NAM=$P(X,"|",6),MDSSN=$P(X,"|",20) I $L(MDSSN)<9 S MDSSN=$P(X,"|",4) 136 S MDSSN=$P(MDSSN,"^",1) I MDSSN'?9N S MDSSN=$TR(MDSSN,"- ","") 137 I $E(MDSSN,$L(MDSSN))="P" S MDSSN=$E(MDSSN,1,9) 138 S:MDSSN'?9N MDSSN=" " S DFN=$O(^DPT("SSN",MDSSN,0)) 139 I 'DFN S DFN=$O(^DPT("SSN",MDSSN_"P",0)) 140 Q 141 ; 142 OBX ; [Observation] 143 ;Q:$P(^TMP($J,"MDHL7A",NUM),"|")'="OBX" 144 D @MDRTN 145 Q 146 NEWID(DFN,DATE,INST,MDD702,HLMTIEN) ; Generate a new entry and ID of 703.1 147 N NEWID,MDFDA,MDIEN 148 S NEWID=$TR($H,",","-") ; Create inital ID 149 L +(^MDD(703.1,"B")):60 E Q "-1" 150 ;^^--- Unable to get an lock in the file 151 F Q:'$D(^MDD(703.1,"B",NEWID)) H 1 S NEWID=$TR($H,",","-") 152 ;^^--- Search to create an new ID in current ID is in use 153 S MDFDA(703.1,"+1,",.01)=NEWID 154 S MDFDA(703.1,"+1,",.02)=DFN 155 S MDFDA(703.1,"+1,",.03)=$$HL7TFM^MDHL7U(DATE) 156 S MDFDA(703.1,"+1,",.04)=INST 157 S MDFDA(703.1,"+1,",.05)=MDD702 158 S MDFDA(703.1,"+1,",.06)=HLMTIEN 159 D UPDATE^DIE("","MDFDA","MDIEN") 160 L -(^MDD(703.1,"B")) 161 I $G(MDIEN(1))>0 S ^MDD(703.1,MDIEN(1),.1,0)="^703.11S^0^0" Q MDIEN(1)_U_NEWID 162 ; ^^--- Create Subfile and quit 163 Q "-1" ; Unable to create file 164 ; 165 PROC ; [Procedure] Create report entry in file (703.1) 166 D PROC^MDHL7U 167 Q -
WorldVistAEHR/trunk/r/CLINICAL_PROCEDURES-MD/MDHL7MCA.m
r613 r623 1 MDHL7MCA ; HOIFO/REL-Routine to Decode HL7 for MEDICINE ; [05-07-2001 10:38]2 ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102 3 4 5 6 ; Reference DBIA #10096 for ^%ZOSF calls. 7 EN ; Entry Point for Message Array inMSG8 N MSG 9 K ERRTX 10 S MDERROR=0 11 ;F I=3:1 X HLNEXT Q:HLQUIT'>0 S MSG(I)=HLNODE,J=0 F S J=$O(HLNODE(J)) Q:'J S MSG(I,J)=HLNODE(J)12 M MSG=^TMP($J,"MDHL7A") 13 S NUM=1 14 MSH ; Decode MSH 15 K SEG 16 I '$D(MSG(NUM)) G KIL 17 S X=$G(MSG(NUM)),SEG("MSH")=X,MCAPP="" 18 I $E(X,1,3)'="MSH" S ERRTX="MSH not first record" D ^MDHL7MCXG KIL19 S MCAPP=$P(MSG(NUM),"|",4) I MCAPP="" G KIL 20 S NUM=NUM+1 21 PID ; Check PID 22 S X=$G(MSG(NUM)) I $E(X,1,3)'="PID" S ERRTX="PID not second record" D ^MDHL7MCX G KIL 23 S SEG("PID")=X 24 S NAM=$P(X,"|",6),MDSSN=$P(X,"|",20) I $L(MDSSN)<9 S MDSSN=$P(X,"|",4)25 S MDSSN=$P(MDSSN,"^",1) I MDSSN'?9N S MDSSN=$TR(MDSSN,"- ","")26 S:MDSSN'?9N MDSSN=" " S DFN=$O(^DPT("SSN",MDSSN,0)) 27 I 'DFN S ERRTX="SSN not found" D ^MDHL7MCX G KIL 28 S Z1=$P($G(^DPT(DFN,0)),",",1),Z2=$P(NAM,"^",1)29 S Z1=$TR(Z1,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ")30 S Z2=$TR(Z2,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 31 I $E(Z1,1,3)'=$E(Z2,1,3) S ERRTX="Last Name MisMatch" D ^MDHL7MCX G KIL 32 D PID^VADPT6 S PID=$G(VA("PID")),BID=$G(VA("BID")) K VA 33 ; If DFN not a medical patient, add DFN to medical patient file 34 I '$D(^MCAR(690,DFN)) S ^MCAR(690,DFN,0)=DFN,^MCAR(690,"B",DFN,DFN)="",$P(^MCAR(690,0),U,4)=$P(^MCAR(690,0),U,4)+1 S:$P(^MCAR(690,0),U,3)<DFN $P(^MCAR(690,0),U,3)=DFN 35 S NUM=NUM+1 36 ; Skip PV1, ORC if necessary 37 LPOBR I $E(MSG(NUM),1,3)'="OBR" S NUM=NUM+1 G LPOBR 38 ;I $E(MSG(NUM),1,3)="ORC" S NUM=NUM+1 39 OBR ; Check OBR 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 PROC 55 56 57 58 P1 59 60 61 KIL 62 63 64 65 66 1 MDHL7MCA ; HIRMFO/REL-Routine to Decode HL7 for MEDICINE ; [05-07-2001 10:38] 2 ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004 3 ; Reference DBIA #10035 for DPT calls. 4 ; Reference DBIA #10062 for VADPT calls. 5 ; Reference DBIA #10106 for HL7 calls. 6 EN ; Entry Point for Message Array in MSG 7 N MSG 8 K ERRTX 9 S MDERROR=0 10 ;F I=3:1 X HLNEXT Q:HLQUIT'>0 S MSG(I)=HLNODE,J=0 F S J=$O(HLNODE(J)) Q:'J S MSG(I,J)=HLNODE(J) 11 M MSG=^TMP($J,"MDHL7A") 12 S NUM=1 13 MSH ; Decode MSH 14 K SEG 15 I '$D(MSG(NUM)) G KIL 16 S X=$G(MSG(NUM)),SEG("MSH")=X,MCAPP="" 17 I $E(X,1,3)'="MSH" S ERRTX="MSH not first record" D ^MDHL7MCX G KIL 18 S MCAPP=$P(MSG(NUM),"|",4) I MCAPP="" G KIL 19 S NUM=NUM+1 20 PID ; Check PID 21 S X=$G(MSG(NUM)) I $E(X,1,3)'="PID" S ERRTX="PID not second record" D ^MDHL7MCX G KIL 22 S SEG("PID")=X 23 S NAM=$P(X,"|",6),MDSSN=$P(X,"|",20) I $L(MDSSN)<9 S MDSSN=$P(X,"|",4) 24 S MDSSN=$P(MDSSN,"^",1) I MDSSN'?9N S MDSSN=$TR(MDSSN,"- ","") 25 S:MDSSN'?9N MDSSN=" " S DFN=$O(^DPT("SSN",MDSSN,0)) 26 I 'DFN S ERRTX="SSN not found" D ^MDHL7MCX G KIL 27 S Z1=$P($G(^DPT(DFN,0)),",",1),Z2=$P(NAM,"^",1) 28 S Z1=$TR(Z1,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 29 S Z2=$TR(Z2,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 30 I $E(Z1,1,3)'=$E(Z2,1,3) S ERRTX="Last Name MisMatch" D ^MDHL7MCX G KIL 31 D PID^VADPT6 S PID=$G(VA("PID")),BID=$G(VA("BID")) K VA 32 ; If DFN not a medical patient, add DFN to medical patient file 33 I '$D(^MCAR(690,DFN)) S ^MCAR(690,DFN,0)=DFN,^MCAR(690,"B",DFN,DFN)="",$P(^MCAR(690,0),U,4)=$P(^MCAR(690,0),U,4)+1 S:$P(^MCAR(690,0),U,3)<DFN $P(^MCAR(690,0),U,3)=DFN 34 S NUM=NUM+1 35 ; Skip PV1, ORC if necessary 36 LPOBR I $E(MSG(NUM),1,3)'="OBR" S NUM=NUM+1 G LPOBR 37 ;I $E(MSG(NUM),1,3)="ORC" S NUM=NUM+1 38 OBR ; Check OBR 39 W MSG(NUM) 40 S X=$G(MSG(NUM)) I $E(X,1,3)'="OBR" S ERRTX="OBR not found when expected" D ^MDHL7MCX G KIL 41 S SEG("OBR")=X 42 S ORIFN=$P(X,"|",3),INST=$P(X,"|",25) I MCAPP="Instrument Manager",INST'="" S MCAPP=INST 43 S ORIFN=$P(X,"|",3),(EXAM,%)=$P(X,"|",5) I EXAM'="" S EXAM=$P(%,"^",2),EXAM2=$P(%,"^",1) I EXAM="" S EXAM=EXAM2 44 S CPT=$P(X,"|",5) I $P(CPT,"^",3)["CPT" S CPT=$P(CPT,"^",1) 45 S DTO="",DATE=$P(X,"|",8) I DATE'="" S:$L(DATE)>14 DATE=$E(DATE,1,14) S DTO=$$FMDATE^HLFNC(DATE) 46 I DTO="" S ERRTX="Missing required Date/Time of Procedure in OBR" D ^MDHL7MCX G KIL 47 K SET S SET=DTO_"^"_DFN,NUM=NUM+1,ICNT=0 K IMP 48 ; Go to Application 49 S INST=$O(^MCAR(690.7,"B",MCAPP,0)) I 'INST S X=MCAPP,ERRTX="Invalid Application Code" D ^MDHL7MCX G KIL 50 S MCRTN=$G(^MCAR(690.7,INST,1)) S:MCRTN'["^" MCRTN="^"_MCRTN 51 ; test for existence 52 S X=MCRTN S:X["^" X=$P(X,"^",2) X ^%ZOSF("TEST") I '$T S ERRTX="Processing routine not found" D ^MDHL7MCX G KIL 53 D @MCRTN G KIL 54 PROC ; Create Procedure entry in appropriate file (FIL) 55 I $P(SET,"^",1)=""!($P(SET,"^",2)="") Q 56 S DA=0 F S DA=$O(^MCAR(FIL,"B",$P(SET,"^",1),DA)) Q:'DA I $P($G(^MCAR(FIL,DA,0)),"^",1,2)=SET Q 57 Q:DA 58 P1 L +^MCAR(FIL,0):3 G:'$T P1 S DA=$P(^MCAR(FIL,0),"^",3)+1,$P(^MCAR(FIL,0),"^",3,4)=DA_"^"_DA L -^MCAR(FIL,0) 59 I $D(^MCAR(FIL,DA)) G P1 60 S ^MCAR(FIL,DA,0)=SET S DIK="^MCAR("_FIL_"," D IX1^DIK Q 61 KIL ; Kill Variables 62 K %,BID,CODE,CPT,DA,DATE,DFN,DIK,DLCO,DTO,ERRTX,EXAM,EXAM2,EXE,FIL 63 K I,ICNT,ID,IMP,J,K,LBL,LINE,LN,MCAPP,MCRTN,MG,MSG,N,NAM,NEXT,NUM 64 K ORIFN,P,PID,PIEN,S,SEG,SEP,SET,MDSSN,STR,STYP,SUB,TCNT,TXT 65 K UNITS,VA,VAL,X,XMBODY,XMDUZ,XMSUBJ,XMTO,Z1,Z2 66 Q -
WorldVistAEHR/trunk/r/CLINICAL_PROCEDURES-MD/MDHL7U3.m
r613 r623 1 MDHL7U3 ; HOIFO/WAA -Utilities for CP to process HL7 messages ; 7/26/00 2 ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102 3 ; Reference DBIA #2729 [Supported] for XMXPAI 4 ; Reference DBIA #4262 [Supported] for HL7 call. 5 ; Reference DBIA #3273 [Subscription] for HL7 call. 6 ; Reference DBIA #10138 [Supported] for HL7 call. 7 ; Reference DBIA #3990 [Supported] for ICDCODE call 8 ; Reference DBIA #1131 [Supported] for XMB("NETNAME") reference 9 ; Reference DBIA #1995 [Supported] for ICPTCOD to handle CPT Codes call 10 ; Reference DBIA #10082 [Supported] for ^ICD9 reference 11 ; Reference DBIA #10111 [Supported] for FILE 3.8 call 12 ; Reference DBIA #10103 [Supported] for XLFDT call 13 ; 14 HL7CHK(MDD702) ; Check to see of there is an entry in 703.1 for a patient. 15 N X 16 S X="1^" 17 D 18 . N Y 19 . I $G(^MDD(702,MDD702,0))="" S X="-1^No Entry in 702." Q 20 . I $D(^MDD(703.1,"ASTUDYID",MDD702))=0 Q 21 . S Y=0 22 . S Y=$O(^MDD(703.1,"ASTUDYID",MDD702,Y)) I Y>0 S X="-1^This Study has Data on file." 23 . Q 24 Q X 25 XVERT(MDA,MDB) ; Strip out blank Lines 26 Q:MDA="" 27 Q:MDB="" 28 Q:$G(^TMP($J,MDA,1)) 29 N I,CNT,CNT2,NODE,FLG 30 S (CNT,I,FLG)=0 31 F S I=$O(^TMP($J,MDA,I)) Q:I<1 D 32 . S NODE=$TR(^TMP($J,MDA,I),$C(10),"") 33 . I NODE="" S FLG=0 Q 34 . I FLG D Q 35 . . S CNT2=CNT2+1 36 . . S ^TMP($J,MDB,CNT,CNT2)=NODE 37 . . Q 38 . I 'FLG D Q 39 . . S CNT=CNT+1 40 . . S ^TMP($J,MDB,CNT)=NODE 41 . . S FLG=1,CNT2=0 42 . . Q 43 . Q 44 Q 45 ; 46 PURGE(MDD7031) ; 47 ; This sub-routine will delete HL7 772 Message text after a message 48 ; been processed by Imaging. 49 Q:'$D(^MDD(703.1,MDD7031,0)) ; No entry found 50 S MDD772=$P(^MDD(703.1,MDD7031,0),U,6) Q:MDD772="" 51 D DELBODY^HLUOPT2(MDD772,"CLINICAL PROCEDURES message purge","^TMP($J,""IN"")") 52 S $P(^MDD(703.1,MDD7031,0),U,6)="" 53 Q 54 ; 55 PHY(X,MDIEN) ; Add the doc who did the exam to the report 56 Q 57 ; This will be implemented with the Doctor Lookup when it comes out. 58 N LINE1,LINE 59 S LINE1=$P(X,"|",17) 60 S LINE=$P(LINE1,"^",2) ; Last 61 S LINE=LINE_$S($P(LINE1,"^",3)'="":", "_$P(LINE1,"^",3),1:"") ; First 62 S LINE=LINE_$S($P(LINE1,"^",4)'="":" "_$P(LINE1,"^",4),1:"") ; MI 63 D ADD(MDIEN,"9",LINE) 64 Q 65 ; 66 CPTICD(X,MDIEN) ; Break out CPT and ICD9 codes 67 N ICD,CPT 68 Q:MDIEN<1 69 S CPT=$P(X,"|",45) I CPT'="" D FILECD(MDIEN,CPT,"7") 70 S ICD=$P(X,"|",14) I ICD'="" D FILECD(MDIEN,ICD,"8") 71 Q 72 FILECD(MDIEN,CODE,TYPE) ; fILE THE DATA 73 N LINE,Y,I,CNT,RESULT 74 S CNT=$L(CODE,"~") 75 S LINE="" 76 F I=1:1:CNT S Y=$P(CODE,"~",I),RESULT=$P(Y,"^",1),LINE(.2,I,0)=RESULT 77 S LINE(.2,0)="^^"_CNT_"^"_CNT_"^"_$P(%,".") 78 Q:CNT<1 ; file the results if there is any 79 D ADD(MDIEN,TYPE,.LINE,CNT) 80 Q 81 ; 82 ADD(MDIEN,TYPE,LINE,CNT) ; 83 ; Create an entry in the .1 node 84 N NODE,X 85 S NODE=$G(^MDD(703.1,MDIEN,.1,0)) Q:NODE="" 86 S NODE=$P(NODE,"^",3) 87 S NODE=NODE+1 88 S $P(^MDD(703.1,MDIEN,.1,0),"^",3,4)=NODE_"^"_NODE 89 S $P(^MDD(703.1,MDIEN,.1,NODE,0),"^")=TYPE 90 D NOW^%DTC 91 M ^MDD(703.1,MDIEN,.1,NODE)=LINE 92 Q 93 ; 94 MSGIEN(MDHLIENS,MDHLREST) ; Return the message as definded in MDHLIENS to the array in MDHLREST 95 ; Only TCP type messages 96 ; input: MDHLIENS= the intern entry number of the message in ^HLMA 97 ; MDHLREST = the return array that will contain the whole HL7 message 98 ; output: return "1^Message complete" if message was successful, "0^reason" if failed. 99 ; 100 N MDHLIEN,MDHLI,MDHLCNT,MDHLZ,RET 101 S (MDHLCNT,MDHLI,RET)=0 102 I $G(MDHLIENS)="" S RET=RET_"^No IEN defined" Q RET ; Exit because no IEN for ^HLMA was provided 103 I $G(MDHLREST)="" S RET=RET_"^No Return ARRAY provided" Q RET ; Exit because no return array was provided 104 I $G(^HLMA(MDHLIENS,0))="" S RET=RET_"^HLMA entry does not exist" Q RET ; Exit because invalid OR non-EXISTING HLMA ENTRY 105 S MDHLIEN=$P(^HLMA(MDHLIENS,0),U) 106 I MDHLIEN="" S RET=RET_"^No pointer value to file 772" Q RET ; No Pointer to 772 107 I $G(^HL(772,MDHLIEN,0))="" S RET=RET_"^772 Entry does not exist" Q RET ; No 772 entry exist 108 ;get header 109 S MDHLZ=$G(^HLMA(MDHLIENS,"MSH",1,0)) 110 I MDHLZ="" S RET=RET_"^No MSH segment found" Q RET ; No MSH was found 111 S MDHLCNT=MDHLCNT+1,@MDHLREST@(MDHLCNT)=MDHLZ 112 S MDHLCNT=MDHLCNT+1,@MDHLREST@(MDHLCNT)="" 113 ;get body 114 S MDHLI=0 115 F S MDHLI=$O(^HL(772,MDHLIEN,"IN",MDHLI)) Q:'MDHLI D 116 . S MDHLCNT=MDHLCNT+1 117 . S @MDHLREST@(MDHLCNT)=$G(^HL(772,MDHLIEN,"IN",MDHLI,0)) 118 . Q 119 I MDHLCNT'>2 S RET=RET_"^No message body found" Q RET ; There was no body 120 S RET="1^Message complete" 121 Q RET 122 ; 123 CICNV(MDIEN,RETURN) ; This subroutine will read the data in 703.1 and return the results 124 ;in the indicated global 125 N NODE,FLG 126 S FLG=1 127 Q:MDIEN="" ; The ien was null 128 Q:RETURN="" ; the array was null 129 S ARRAY(0)="0^0" 130 I $G(^MDD(703.1,MDIEN,.1,0))="" S FLG=0 Q ; There is not data. 131 ; Start the processing of ICD/POV codes Value is 8 132 S NODE=0 133 I FLG I $G(^MDD(703.1,MDIEN,.1,0))'="" D 134 . F S NODE=$O(^MDD(703.1,MDIEN,.1,NODE)) Q:NODE<1 D 135 . . S TYPE=$P($G(^MDD(703.1,MDIEN,.1,NODE,0),0),"^",1) 136 . . I TYPE=8 D PROCESS(MDIEN,NODE,TYPE,.ARRAY) 137 . . I TYPE=7 D PROCESS(MDIEN,NODE,TYPE,.ARRAY) 138 . . Q 139 . Q 140 M @RETURN=ARRAY 141 Q 142 PROCESS(MDIEN,NODE,TYPE,ARRAY) ; This will process the data for each 143 N CNT,X,CONT,CODE,AR,TP,LOC 144 S CNT=0,CONT=0 145 F S CNT=$O(^MDD(703.1,MDIEN,.1,NODE,.2,CNT)) Q:CNT<1 D 146 . S CODE=$G(^MDD(703.1,MDIEN,.1,NODE,.2,CNT,0),"") ; Grabbing the ICD9 AND CPT codes 147 . I CODE="" Q 148 . I TYPE=8 S AR=1,TP="POV",X=$$ICDDX^ICDCODE(CODE) Q:X="" ; Reference DBIA #3990 [Supported] for ICDCODE call 149 . I TYPE=7 S AR=2,TP="CPT",X=$$CPT^ICPTCOD(CODE) Q:X="" ; Reference DBIA #1995 [Supported] for ICPTCOD to handle CPT Codes call 150 . S CONT=CONT+1 151 . S ARRAY(AR)=CONT_"^"_CONT 152 . I AR=1 D 153 . . N DESC,IN,LN 154 . . S IN=$P(X,"^",1) Q:IN<1 155 . . S LN=$G(^ICD9(IN,0),0) Q:LN="" 156 . . S DESC=$P(LN,"^",3) Q:DESC="" 157 . . S I=CONT 158 . . S $P(ARRAY(AR,I),"^",1)=TP 159 . . S $P(ARRAY(AR,I),"^",2)=$P(X,"^",1) 160 . . S $P(ARRAY(AR,I),"^",3)=$P(X,"^",2) 161 . . S $P(ARRAY(AR,I),"^",5)=DESC 162 . . S $P(ARRAY(AR,I),"^",6)=$S(I=1:1,1:0) 163 . . Q 164 . I AR=2 D 165 . . N DESC,IN,LN 166 . . S IN=$P(X,"^",1) Q:IN<1 167 . . ; S LN=$G(^ICPT(IN,0),0) Q:LN="" 168 . . S DESC=$P(X,"^",3) Q:DESC="" ; DBIA1995 $$CPT^ICPTCOD(CODE) returns X and the second piece of X is the DESC 169 . . S I=CNT 170 . . S $P(ARRAY(AR,I),"^",1)=TP 171 . . S $P(ARRAY(AR,I),"^",2)=$P(X,"^",1) 172 . . S $P(ARRAY(AR,I),"^",3)=$P(X,"^",2) 173 . . S $P(ARRAY(AR,I),"^",5)=DESC 174 . . S $P(ARRAY(AR,I),"^",7)=$S(I=1:1,1:0) 175 . . Q 176 . Q 177 I $D(ARRAY(1))!$D(ARRAY(2)) S ARRAY(0)="1^1" 178 Q 179 ; 180 NOTICE(SUBJECT,TXT,DEVIEN,DUZ) ; This will fire off a mail message to the Indicated mail group saying that a study was deleted 181 ; 182 N INST,MG,XMTO,XMDUZ,XMSUBJ,XMBODY,N,X 183 S MG=0 184 S INST=DEVIEN 185 I INST>1 S MG=$P($G(^MDS(702.09,INST,0)),"^",2) 186 I 'MG!('$$MG^MDHL7U2(MG)) S MG=$$FIND1^DIC(3.8,"","BX","MD DEVICE ERRORS") Q:'MG 187 S MG=$$GET1^DIQ(3.8,+MG_",",.01) 188 S XMTO="G."_MG_"@"_^XMB("NETNAME"),XMINSTR("FROM")=.5 189 S XMBODY="TXT" 190 S XMSUBJ=SUBJECT 191 D SENDMSG^XMXAPI(DUZ,XMSUBJ,XMBODY,XMTO,.XMINSTR) 192 Q 193 ; 194 ALERT(MDSIEN) ; This is to send an e-mail to the main device mail group that a study has been deleted 195 D NOW^%DTC 196 S SUBJECT="Study "_MDSIEN_" for Patient "_$$GET1^DIQ(702,MDSIEN,.01,"E")_" has been DELETED!" 197 S BODY(1)="The following study has been deleted." 198 S BODY(2)=" By the USER: "_$$GET1^DIQ(200,DUZ,.01,"E") 199 S BODY(3)=" On Date: "_$$FMTE^XLFDT(%,1) 200 S BODY(4)=" " 201 S BODY(5)=" CP Study Information" 202 S BODY(6)="------------------------------------------------------------------------------ " 203 S BODY(7)="CP Study ID: "_MDSIEN 204 S BODY(8)="CP Study Def: "_$$GET1^DIQ(702,MDSIEN,.04,"E") 205 S BODY(9)="Created on: "_$$FMTE^XLFDT($$GET1^DIQ(702,MDSIEN,.02,"I"),1) 206 S BODY(10)="Created by: "_$$GET1^DIQ(702,MDSIEN,.03,"E") 207 S BODY(11)="On Instrument: "_$$GET1^DIQ(702,MDSIEN,.11,"E") 208 S BODY(12)="For Patient: "_$$GET1^DIQ(702,MDSIEN,.01,"E") 209 S BODY(13)=" SSN: "_$E($$GET1^DIQ(702,MDSIEN,.011,"E"),6,9) 210 S BODY(14)=" DOB: "_$$FMTE^XLFDT($$GET1^DIQ(702,MDSIEN,.012,"I"),1) 211 S DEVIEN=$$GET1^DIQ(702,MDSIEN,.11,"I") 212 Q 1 MDHL7U3 ; HOIFO/WAA -Utilities for CP to process HL7 messages ; 7/26/00 2 ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004 3 ; Reference DBIA #4262 [Supported] for HL7 call. 4 ; 5 PURGE(MDD7031) ; 6 ; This sub-routine will delete HL7 772 Message text after a message 7 ; been processed by Imaging. 8 Q:'$D(^MDD(703.1,MDD7031,0)) ; No entry found 9 S MDD772=$P(^MDD(703.1,MDD7031,0),U,6) Q:MDD772="" 10 D DELBODY^HLUOPT2(MDD772,"CLINICAL PROCEDURES message purge","^TMP($J,""IN"")") 11 S $P(^MDD(703.1,MDD7031,0),U,6)="" 12 Q -
WorldVistAEHR/trunk/r/CLINICAL_PROCEDURES-MD/MDHL7X.m
r613 r623 1 MDHL7X 2 ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102 3 4 5 6 7 GENERR 8 9 10 11 12 13 14 I '$D(X) S X=$G(ECODE(0))15 16 17 I '$G(ECODE,1)D ; This is to process Device errors18 19 20 21 22 23 24 25 26 27 28 GENACK 29 30 31 32 33 34 1 MDHL7X ; HOIFO/WAA -Generate HL7 Error Message ; 06/08/00 2 ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004 3 ; Reference IA #1131 for ^XMB("NETNAME") access. 4 ; Reference IA #2165 for HLMA1 calls. 5 ; Reference IA #2729 for XMXAPI calls. 6 D GENERR,GENACK Q 7 GENERR ; Generate error message 8 N TXT,INST,MG,XMTO,XMDUZ,XMSUBJ,XMBODY,N,X S MG=0 9 S INST=DEVIEN 10 I INST>1 S MG=$P($G(^MDS(702.09,INST,0)),"^",2) 11 I 'MG!('$$MG^MDHL7U2(MG)) S MG=$$FIND1^DIC(3.8,"","BX","MD DEVICE ERRORS") Q:'MG 12 S MG=$$GET1^DIQ(3.8,+MG_",",.01) 13 S XMTO="G."_MG_"@"_^XMB("NETNAME"),XMINSTR("FROM")=.5 14 I '$D(X) S X=ECODE(0) 15 S TXT(1)=ERRTX,TXT(2)=X,TXT(3)=" " 16 S N=3 17 I 'ECODE D ; This is to process Device errors 18 . N X 19 . S X=0 20 . F S X=$O(ECODE(X)) Q:X<1 S N=N+1,TXT(N)=ECODE(X) 21 . S N=N+1,TXT(N)=" " 22 . Q 23 F X="MSH","PID","OBR","OBX" I $D(SEG(X)) S N=N+1,TXT(N)=SEG(X) 24 S XMSUBJ="A Clinical Instrument HL7 Error has occurred." 25 S XMBODY="TXT" 26 D SENDMSG^XMXAPI(DUZ,XMSUBJ,XMBODY,XMTO,.XMINSTR) 27 Q 28 GENACK ; Generate an HL7 ACK message 29 ; Reference IA #2165 for GENACK^HLMA1 call 30 N HLA,HLEID,HLEIDS,HLARYTYP,HLFORMAT,HLRESLTA 31 S HLA("HLA",1)="MSA"_HL("FS")_$S($D(ERRTX):"AR",1:"AA")_HL("FS")_HL("MID")_$S($D(ERRTX):HL("FS")_ERRTX,1:"") 32 S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="LM",HLFORMAT=1,HLRESLTA=HL("MID") 33 D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT,.HLRESTLA) 34 N ERRTX Q -
WorldVistAEHR/trunk/r/CLINICAL_PROCEDURES-MD/MDRPCOG.m
r613 r623 1 MDRPCOG ; HOIFO/DP - CP Gateway ; [01-09-2003 15:20] 2 ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102 3 ; Description: 4 ; This is the main routine that manages the CLINICAL PROCEDURES Gateway functions. 5 ; Access to these functions is controlled via the MD GATEWAY RPC. 6 ; 7 ; Integration Agreements: 8 ; IA# 10097 [Supported] %ZOSV calls 9 ; IA# 10103 [Supported] Calls to XLFDT 10 ; IA# 2263 [Supported] Calls to XPAR 11 ; 12 CLEANUP ; [Procedure] Cleanup a past results report 13 F X=0:0 S X=$O(^MDD(703.1,DATA,.1,X)) Q:'X D 14 .S:$G(^MDD(703.1,DATA,.1,X,.1))]"" MDFDA(703.11,X_","_DATA_",",.1)="@" 15 .S:$O(^MDD(703.1,DATA,.1,X,.2,0)) MDFDA(703.11,X_","_DATA_",",.2)="@" 16 D:$D(MDFDA) FILE^DIE("K","MDFDA","MDERR") 17 I $D(MDERR) D ERROR^MDRPCU(RESULTS,.MDERR) Q 18 ; Manual cleanup of the empty UNC nodes and WP root 19 F X=0:0 S X=$O(^MDD(703.1,DATA,.1,X)) Q:'X D 20 .K ^MDD(703.1,DATA,.1,X,.1) 21 .K ^MDD(703.1,DATA,.1,X,.2) 22 S @RESULTS@(0)="1^Item purged" 23 Q 24 ; 25 DONE ; [Procedure] Done processing, Mark study status 26 S MDFDA(703.1,+DATA_",",.09)=$G(P1,"U") 27 D FILE^DIE("","MDFDA") 28 Q 29 ; 30 GETATT ; [Procedure] Get attachments for study 31 F X=0:0 S X=$O(^MDD(703.1,+DATA,.1,X)) Q:'X D 32 .S Y=+$O(@RESULTS@(""),-1)+1 33 .S @RESULTS@(Y)="703.11;"_X_U_^MDD(703.1,+DATA,.1,X,0) 34 S @RESULTS@(0)=+$O(@RESULTS@(""),-1) 35 Q 36 ; 37 GETOLD ; [Procedure] Returns old results by date 38 ; Variables: 39 ; LOGDATE: [Private] Loop variable 40 ; STOPDATE: [Private] Date to stop retrieving entries 41 ; 42 ; New private variables 43 NEW LOGDATE,STOPDATE,MDX 44 S LOGDATE=+DATA,STOPDATE=+$P(DATA,U,2)+.2359 45 F S LOGDATE=$O(^MDD(703.1,"ADTP",LOGDATE)) W !,"-->",LOGDATE Q:'LOGDATE!(LOGDATE>STOPDATE) D Q:Y>50 46 .F MDX=0:0 S MDX=$O(^MDD(703.1,"ADTP",LOGDATE,MDX)) Q:'MDX D 47 ..I '$$CHECK(MDX) Q 48 ..S Y=$O(@RESULTS@(""),-1)+1 49 ..S @RESULTS@(Y)="703.1;"_MDX_U_$G(^MDD(703.1,MDX,0)) 50 S:'LOGDATE!(LOGDATE>STOPDATE) LOGDATE=STOPDATE 51 S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_U_LOGDATE_U_$$FMTE^XLFDT(LOGDATE) 52 Q 53 ; 54 GETPAR ; [Procedure] Get a parameter value for an RPC Call 55 S @RESULTS@(0)=$$PARVAL(DATA) 56 Q 57 ; 58 GETTXT ; [Procedure] Get attachment text for processing 59 N X,STUDY,ATT 60 S X=0,STUDY=$P(DATA,",",2),ATT=+DATA 61 I '$O(^MDD(703.1,STUDY,.1,ATT,.2,0)) S @RESULTS@(0)="-1^No Data" Q 62 F S X=$O(^MDD(703.1,STUDY,.1,ATT,.2,X)) Q:'X S @RESULTS@(X)=^(X,0) 63 S @RESULTS@(0)=+$O(@RESULTS@(""),-1) 64 Q 65 ; 66 NEXT ; [Procedure] Get the next study to process 67 S Y=+$O(^MDD(703.1,"ASTATUS","P",$G(DATA))) 68 S @RESULTS@(0)=$S($D(^MDD(703.1,Y,0)):"703.1;"_Y_U_^MDD(703.1,Y,0),1:0) 69 Q 70 ; 71 PARVAL(INSTANCE) ; [Procedure] Extrinsic get of parameter values 72 ; Input parameters 73 ; 1. INSTANCE [Literal/Required] XPAR instance 74 ; 75 Q $$GET^XPAR("SYS","MD GATEWAY",INSTANCE) 76 ; 77 POLL ; [Procedure] Returns server time and flag for studies to process 78 I $$PARVAL("Shutdown Flag")]"" D Q 79 .S @RESULTS@(0)="-1^SHUTDOWN" 80 .D SETPAR("Shutdown Flag","") 81 S @RESULTS@(0)=$$FMTE^XLFDT($$NOW^XLFDT) 82 S @RESULTS@(1)=$D(^MDD(703.1,"ASTATUS","P")) 83 Q 84 ; 85 POLLER(RESULTS) ; [Procedure] Non-Disk activity poller 86 ; With the exception of a shutdown request pending, this stand alone RPC will operate 87 ; without creating any disk activity and not crash during backup operations on the main 88 ; VistA server. 89 ; 90 ; Input parameters 91 ; 1. RESULTS [Reference/Required] 92 ; 93 I $$PARVAL("Shutdown Flag")]"" D Q 94 .S RESULTS(0)="-1^SHUTDOWN" 95 .D SETPAR("Shutdown Flag","") 96 S RESULTS(0)=$$FMTE^XLFDT($$NOW^XLFDT) 97 S RESULTS(1)=$D(^MDD(703.1,"ASTATUS","P")) 98 Q 99 ; 100 RPC(RESULTS,OPTION,DATA,P1) ; [Procedure] 101 ; Input parameters 102 ; 1. RESULTS [Literal/Required] RPC Return Array 103 ; 2. OPTION [Literal/Required] Gateway Option to execute 104 ; 3. DATA [Literal/Required] Other information 105 ; 4. P1 [Literal/Required] Overflow variable 106 ; 107 ; Variables: 108 ; MDENV: [Private] Server environment variable 109 ; MDERR: [Private] Fileman return array 110 ; MDFDA: [Private] Fileman FDA 111 ; 112 ; New private variables 113 NEW MDENV,MDERR,MDFDA 114 S RESULTS=$NA(^TMP("MDRPCOB",$J)) K @RESULTS 115 D @OPTION 116 Q 117 ; 118 RUNNING ; [Procedure] Returns 0/1 and message on running status 119 ; Note: If lock CAN be obtained, then gateway is NOT running 120 L +^MDD("CPGATEWAY"):1 E S @RESULTS@(0)="1^RUNNING" Q 121 L -(^MDD("CPGATEWAY")) S @RESULTS@(0)="0^NOT RUNNING" 122 Q 123 ; 124 SETFILE ; [Procedure] Set filename of new attachment 125 S MDFDA(703.11,$P(DATA,U,1),.02)=$P(DATA,U,2) 126 D FILE^DIE("","MDFDA") 127 Q 128 ; 129 SETPAR(INSTANCE,VALUE) ; [Procedure] Set value into XPAR parameter 130 ; Input parameters 131 ; 1. INSTANCE [Literal/Required] Parameter Instance 132 ; 2. VALUE [Literal/Required] Parameter Value 133 ; 134 D EN^XPAR("SYS","MD GATEWAY",INSTANCE,VALUE) 135 Q 136 ; 137 START ; [Procedure] Can we begin? 138 ; Ensure only one Gateway per system by locking the phantom global node 139 L +^MDD("CPGATEWAY"):1 140 I '$T D STATUS S @RESULTS@(0)="-1^FAIL" Q 141 ; Clear all process settings 142 D NDEL^XPAR("SYS","MD GATEWAY") 143 S DATA=$G(DATA,"30^1000") ; Default poll interval and log entries 144 D SETPAR("Polling Interval",+$P(DATA,U,1)) 145 D SETPAR("Maximum Log Entries",+$P(DATA,U,2)) 146 D SETPAR("Job ID",$J) 147 D SETPAR("Started At",$$FMTE^XLFDT($$NOW^XLFDT)) 148 D SETPAR("Started By",$$GET1^DIQ(200,DUZ_",",.01)) 149 D GETENV^%ZOSV S MDENV=Y 150 D SETPAR("UCI",$P(MDENV,U,1)) 151 D SETPAR("Volume",$P(MDENV,U,2)) 152 D SETPAR("Node",$P(MDENV,U,3)) 153 D SETNM^%ZOSV("CP Gateway") 154 S @RESULTS@(0)="1^OK" 155 Q 156 ; 157 STATUS ; [Procedure] Return status of BP 158 D GETLST^XPAR(.MDRET,"SYS","MD GATEWAY","Q") 159 F X=0:0 S X=$O(MDRET(X)) Q:'X S @RESULTS@(X)=MDRET(X) 160 Q 161 ; 162 STOP ; [Procedure] Flag client to stop via cal to POLL 163 D SETPAR("Shutdown Flag","Yes") 164 Q 165 ; 166 XFERDIR ; [Procedure] Return Imaging xfer directory 167 S @RESULTS@(0)=$$GET^XPAR("SYS","MD IMAGING XFER") 168 Q 169 ; 170 CHECK(MDRI) ; Check if Upload Value and Upload Text has already been purged. 171 N MDFLG S MDFLG=0 172 F X=0:0 S X=$O(^MDD(703.1,MDRI,.1,X)) Q:'X D Q:MDFLG 173 .S:$G(^MDD(703.1,MDRI,.1,X,.1))]"" MDFLG=1 174 .S:$O(^MDD(703.1,MDRI,.1,X,.2,0)) MDFLG=1 175 Q MDFLG 1 MDRPCOG ; HOIFO/DP - CP Gateway ; [01-09-2003 15:20] 2 ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004 3 ; Description: 4 ; This is the main routine that manages the CLINICAL PROCEDURES Gateway functions. 5 ; Access to these functions is controlled via the MD GATEWAY RPC. 6 ; 7 ; Integration Agreements: 8 ; IA# 10097 [Supported] %ZOSV calls 9 ; IA# 10103 [Supported] Calls to XLFDT 10 ; IA# 2263 [Supported] Calls to XPAR 11 ; 12 CLEANUP ; [Procedure] Cleanup a past results report 13 F X=0:0 S X=$O(^MDD(703.1,DATA,.1,X)) Q:'X D 14 .S:$G(^MDD(703.1,DATA,.1,X,.1))]"" MDFDA(703.11,X_","_DATA_",",.1)="@" 15 .S:$O(^MDD(703.1,DATA,.1,X,.2,0)) MDFDA(703.11,X_","_DATA_",",.2)="@" 16 D:$D(MDFDA) FILE^DIE("K","MDFDA","MDERR") 17 I $D(MDERR) D ERROR^MDRPCU(RESULTS,.MDERR) Q 18 ; Manual cleanup of the empty UNC nodes and WP root 19 F X=0:0 S X=$O(^MDD(703.1,DATA,.1,X)) Q:'X D 20 .K ^MDD(703.1,DATA,.1,X,.1) 21 .K ^MDD(703.1,DATA,.1,X,.2) 22 S @RESULTS@(0)="1^Item purged" 23 Q 24 ; 25 DONE ; [Procedure] Done processing, Mark study status 26 S MDFDA(703.1,+DATA_",",.09)=$G(P1,"U") 27 D FILE^DIE("","MDFDA") 28 Q 29 ; 30 GETATT ; [Procedure] Get attachments for study 31 F X=0:0 S X=$O(^MDD(703.1,+DATA,.1,X)) Q:'X D 32 .S Y=+$O(@RESULTS@(""),-1)+1 33 .S @RESULTS@(Y)="703.11;"_X_U_^MDD(703.1,+DATA,.1,X,0) 34 S @RESULTS@(0)=+$O(@RESULTS@(""),-1) 35 Q 36 ; 37 GETOLD ; [Procedure] Returns old results by date 38 ; Variables: 39 ; LOGDATE: [Private] Loop variable 40 ; STOPDATE: [Private] Date to stop retrieving entries 41 ; 42 ; New private variables 43 NEW LOGDATE,STOPDATE,MDX 44 S LOGDATE=+DATA,STOPDATE=+$P(DATA,U,2)+.2359 45 F S LOGDATE=$O(^MDD(703.1,"ADTP",LOGDATE)) W !,"-->",LOGDATE Q:'LOGDATE!(LOGDATE>STOPDATE) D Q:Y>50 46 .F MDX=0:0 S MDX=$O(^MDD(703.1,"ADTP",LOGDATE,MDX)) Q:'MDX D 47 ..I '$$CHECK(MDX) Q 48 ..S Y=$O(@RESULTS@(""),-1)+1 49 ..S @RESULTS@(Y)="703.1;"_MDX_U_$G(^MDD(703.1,MDX,0)) 50 S:'LOGDATE!(LOGDATE>STOPDATE) LOGDATE=STOPDATE 51 S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_U_LOGDATE_U_$$FMTE^XLFDT(LOGDATE) 52 Q 53 ; 54 GETPAR ; [Procedure] Get a parameter value for an RPC Call 55 S @RESULTS@(0)=$$PARVAL(DATA) 56 Q 57 ; 58 GETTXT ; [Procedure] Get attachment text for processing 59 N X,STUDY,ATT 60 S X=0,STUDY=$P(DATA,",",2),ATT=+DATA 61 I '$O(^MDD(703.1,STUDY,.1,ATT,.2,0)) S @RESULTS@(0)="-1^No Data" Q 62 F S X=$O(^MDD(703.1,STUDY,.1,ATT,.2,X)) Q:'X S @RESULTS@(X)=^(X,0) 63 S @RESULTS@(0)=+$O(@RESULTS@(""),-1) 64 Q 65 ; 66 NEXT ; [Procedure] Get the next study to process 67 S Y=+$O(^MDD(703.1,"ASTATUS","P",$G(DATA))) 68 S @RESULTS@(0)=$S($D(^MDD(703.1,Y,0)):"703.1;"_Y_U_^MDD(703.1,Y,0),1:0) 69 Q 70 ; 71 PARVAL(INSTANCE) ; [Procedure] Extrinsic get of parameter values 72 ; Input parameters 73 ; 1. INSTANCE [Literal/Required] XPAR instance 74 ; 75 Q $$GET^XPAR("SYS","MD GATEWAY",INSTANCE) 76 ; 77 POLL ; [Procedure] Returns server time and flag for studies to process 78 I $$PARVAL("Shutdown Flag")]"" D Q 79 .S @RESULTS@(0)="-1^SHUTDOWN" 80 .D SETPAR("Shutdown Flag","") 81 S @RESULTS@(0)=$$FMTE^XLFDT($$NOW^XLFDT) 82 S @RESULTS@(1)=$D(^MDD(703.1,"ASTATUS","P")) 83 Q 84 ; 85 POLLER(RESULTS) ; [Procedure] Non-Disk activity poller 86 ; With the exception of a shutdown request pending, this stand alone RPC will operate 87 ; without creating any disk activity and not crash during backup operations on the main 88 ; VistA server. 89 ; 90 ; Input parameters 91 ; 1. RESULTS [Reference/Required] 92 ; 93 I $$PARVAL("Shutdown Flag")]"" D Q 94 .S RESULTS(0)="-1^SHUTDOWN" 95 .D SETPAR("Shutdown Flag","") 96 S RESULTS(0)=$$FMTE^XLFDT($$NOW^XLFDT) 97 S RESULTS(1)=$D(^MDD(703.1,"ASTATUS","P")) 98 Q 99 ; 100 RPC(RESULTS,OPTION,DATA,P1) ; [Procedure] 101 ; Input parameters 102 ; 1. RESULTS [Literal/Required] RPC Return Array 103 ; 2. OPTION [Literal/Required] Gateway Option to execute 104 ; 3. DATA [Literal/Required] Other information 105 ; 4. P1 [Literal/Required] Overflow variable 106 ; 107 ; Variables: 108 ; MDENV: [Private] Server environment variable 109 ; MDERR: [Private] Fileman return array 110 ; MDFDA: [Private] Fileman FDA 111 ; 112 ; New private variables 113 NEW MDENV,MDERR,MDFDA 114 S RESULTS=$NA(^TMP("MDRPCOB",$J)) K @RESULTS 115 D @OPTION 116 Q 117 ; 118 SETFILE ; [Procedure] Set filename of new attachment 119 S MDFDA(703.11,$P(DATA,U,1),.02)=$P(DATA,U,2) 120 D FILE^DIE("","MDFDA") 121 Q 122 ; 123 SETPAR(INSTANCE,VALUE) ; [Procedure] Set value into XPAR parameter 124 ; Input parameters 125 ; 1. INSTANCE [Literal/Required] Parameter Instance 126 ; 2. VALUE [Literal/Required] Parameter Value 127 ; 128 D EN^XPAR("SYS","MD GATEWAY",INSTANCE,VALUE) 129 Q 130 ; 131 START ; [Procedure] Can we begin? 132 ; Ensure only one Gateway per system by locking the phantom global node 133 L +^MDD("CPGATEWAY"):1 134 I '$T D STATUS S @RESULTS@(0)="-1^FAIL" Q 135 ; Clear all process settings 136 D NDEL^XPAR("SYS","MD GATEWAY") 137 S DATA=$G(DATA,"30^1000") ; Default poll interval and log entries 138 D SETPAR("Polling Interval",+$P(DATA,U,1)) 139 D SETPAR("Maximum Log Entries",+$P(DATA,U,2)) 140 D SETPAR("Job ID",$J) 141 D SETPAR("Started At",$$FMTE^XLFDT($$NOW^XLFDT)) 142 D SETPAR("Started By",$$GET1^DIQ(200,DUZ_",",.01)) 143 D GETENV^%ZOSV S MDENV=Y 144 D SETPAR("UCI",$P(MDENV,U,1)) 145 D SETPAR("Volume",$P(MDENV,U,2)) 146 D SETPAR("Node",$P(MDENV,U,3)) 147 D SETNM^%ZOSV("CP Gateway") 148 S @RESULTS@(0)="1^OK" 149 Q 150 ; 151 STATUS ; [Procedure] Return status of BP 152 D GETLST^XPAR(.MDRET,"SYS","MD GATEWAY","Q") 153 F X=0:0 S X=$O(MDRET(X)) Q:'X S @RESULTS@(X)=MDRET(X) 154 Q 155 ; 156 STOP ; [Procedure] Flag client to stop via cal to POLL 157 D SETPAR("Shutdown Flag","Yes") 158 Q 159 ; 160 XFERDIR ; [Procedure] Return Imaging xfer directory 161 S @RESULTS@(0)=$$GET^XPAR("SYS","MD IMAGING XFER") 162 Q 163 ; 164 CHECK(MDRI) ; Check if Upload Value and Upload Text has already been purged. 165 N MDFLG S MDFLG=0 166 F X=0:0 S X=$O(^MDD(703.1,MDRI,.1,X)) Q:'X D Q:MDFLG 167 .S:$G(^MDD(703.1,MDRI,.1,X,.1))]"" MDFLG=1 168 .S:$O(^MDD(703.1,MDRI,.1,X,.2,0)) MDFLG=1 169 Q MDFLG -
WorldVistAEHR/trunk/r/CLINICAL_PROCEDURES-MD/MDRPCOP.m
r613 r623 1 MDRPCOP ; HOIFO/DP - Object RPCs (TMDPatient) ;3/12/08 09:16 2 ;;1.0;CLINICAL PROCEDURES;**4,6**;Apr 01, 2004;Build 102 3 ; Integration Agreements: 4 ; IA# 2263 [Supported] XPAR calls 5 ; IA# 3027 [Supported] Calls to DGSEC4 6 ; IA# 2981 [Subscription] Calls to GUI~GMRCP5 7 ; IA# 2548 [Supported] ACRP Interface Toolkit APIs. 8 ; IA# 2552 [Supported] AIT API to provide outpatient encounter data. 9 ; IA# 10061 [Supported] VADPT calls. 10 ; IA# 3468 [Subscription] Use GMRCCP APIs. 11 ; IA# 10103 [Supported] Call to XLFDT 12 ; IA# 10039 [Supported] Ward Location File (#42) Access. 13 ; IA# 10035 [Supported] DPT references 14 ; IA# 3613 [Private] GETVST^MDRPCOP API call 15 ; IA# 10099 [Supported] GMRADPT call 16 ; IA# 1096 [Controlled Subscription] ^DGPM("ATID1" x-ref loop 17 ; IA# 358 [Controlled Subscription] FILE 405 references 18 ; 19 ADD(X) ; [Procedure] Add line to @RESULTS@(... 20 S @RESULTS@(+$O(@RESULTS@(""),-1)+1)=X 21 Q 22 ; 23 ALLERGY ; [Procedure] Return Allergies 24 D EN1^GMRADPT I '$O(GMRAL(0)) D Q 25 .I $G(GMRAL)="" S @RESULTS@(0)="No Allergy Assessment" 26 .I $G(GMRAL)=0 S @RESULTS@(0)="No Known Allergies" 27 S @RESULTS@(0)="This patient has the following allergy(ies): " 28 F X=0:0 S X=$O(GMRAL(X)) Q:'X D 29 .S @RESULTS@(X)=$P($G(GMRAL(X)),U,2) 30 Q 31 ; 32 CHKIN ; [Procedure] Check In Study 33 F X=2:1:5 D 34 .I $P(DATA,U,X)]"" S MDFDA(702,$P(DATA,U,1),$P("^.04^.05^.11^.07",U,X))=$P(DATA,U,X) 35 S MDFDA(702,$P(DATA,U,1),.09)=4 ; Status = Checked-In 36 I $P(DATA,U,1)="+1," D 37 .S MDFDA(702,"+1,",.01)=DFN 38 .S MDFDA(702,"+1,",.02)=$$NOW^XLFDT() 39 .S MDFDA(702,"+1,",.03)=DUZ 40 .D UPDATE^DIE("","MDFDA","MDIEN","MDERR") Q:$D(MDERR) 41 .S MDIENS=MDIEN(1)_",",MDHL7=$$SUB^MDHL7B(MDIEN(1)) 42 .I +MDHL7=-1 S MDFDA(702,MDIENS,.09)=2,MDFDA(702,MDIENS,.08)=$P(MDHL7,U,2) 43 .I +MDHL7=1 S MDFDA(702,MDIENS,.09)=5,MDFDA(702,MDIENS,.08)="" 44 .D:$D(MDFDA) FILE^DIE("","MDFDA","MDERR") 45 I $P(DATA,U,1)'="+1," D 46 .D FILE^DIE("","MDFDA","MDERR") Q:$D(MDERR) 47 .S MDIENS=+DATA_"," 48 .S MDHL7=$$SUB^MDHL7B(+MDIENS) 49 .I +MDHL7=-1 S MDFDA(702,MDIENS,.09)=2,MDFDA(702,MDIENS,.08)=$P(MDHL7,U,2) 50 .I +MDHL7=1 S MDFDA(702,MDIENS,.09)=5,MDFDA(702,MDIENS,.08)="" 51 .D:$D(MDFDA) FILE^DIE("","MDFDA","MDERR") 52 ; Patch 6 - Renal Check-In 53 D:+$G(MDIENS) 54 .S X=+$P(^MDD(702,+MDIENS,0),U,4) Q:'X 55 .I $P(^MDS(702.01,X,0),U,6)=2 D Q ; Renal Check-In 56 ..D CP^MDKUTLR(+MDIENS) 57 ..S MDFDA(702,+MDIENS_",",.09)=5 58 ..D FILE^DIE("","MDFDA","MDERR") 59 ; Patch 6 - Renal Check-In 60 I '$D(MDERR) S @RESULTS@(0)="1^OK" Q 61 D ERROR^MDRPCU(RESULTS,.MDERR) 62 Q 63 ; 64 DISPCON ; [Procedure] Display a consult 65 K ^TMP("GMRC",$J) 66 D GUI^GMRCP5(.RESULTS,DATA) 67 Q 68 ; 69 GETCONS ; [Procedure] Get available consults for patient 70 K ^TMP("MDTMP",$J) N MDCDT,MDDY,X1,X2,X 71 S MDDY=$$GET^XPAR("SYS","MD COMPL PROC DISPLAY DAYS",1) 72 S X1=DT,X2=-$S(MDDY>0:+MDDY,1:365) D C^%DTC S MDCDT=X 73 D CPLIST^GMRCCP(DFN,,$NA(^TMP("MDTMP",$J))) 74 S MDX=0 75 F S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX D:"saprc"[$P(^(MDX),U,4) 76 .S Y="123;"_$P(^TMP("MDTMP",$J,MDX),U,5) 77 .I $P($G(^TMP("MDTMP",$J,MDX)),U,4)="c" Q:$P($G(^TMP("MDTMP",$J,MDX)),U,1)<MDCDT 78 .F X=2,3,4,1,6,5 S Y=Y_U_$P(^TMP("MDTMP",$J,MDX),U,X) 79 .S Y=Y_U_+$O(^MDD(702,"ACON",+$P(^TMP("MDTMP",$J,MDX),U,5))) 80 .; 81 .; Patch MD*1.0*4 - Return number of times checked in at piece 9 82 .; 83 .S (X,Z)=0,MDY=+$P(^TMP("MDTMP",$J,MDX),U,5) 84 .F S X=$O(^MDD(702,"ACON",MDY,X)) Q:'X S Z=Z+1 85 .S $P(Y,U,9)=Z 86 .; 87 .; End Patch MD*1.0*4 88 .; 89 .D ADD(Y) 90 S @RESULTS@(0)=+$O(@RESULTS@(""),-1) 91 K ^TMP("MDTMP",$J) 92 Q 93 ; 94 GETHDR ; [Procedure] Get Pt Header 95 S DFNIENS=DFN_"," 96 S @RESULTS@(0)=$$GET1^DIQ(2,DFNIENS,.01)_" "_$$GET1^DIQ(2,DFNIENS,.1)_" "_$$GET1^DIQ(2,DFNIENS,.101) 97 S @RESULTS@(1)=$$GET1^DIQ(2,DFNIENS,.09)_" "_$$GET1^DIQ(2,DFNIENS,.02)_" "_$$GET1^DIQ(2,DFNIENS,.03)_" ("_$$GET1^DIQ(2,DFNIENS,.033)_")" 98 Q 99 ; 100 GETOBJ ; [Procedure] Get information for TMDPATIENT object 101 D DEM^VADPT,INP^VADPT 102 S @RESULTS@(0)=DFN 103 S @RESULTS@(1)=VADM(1) 104 S @RESULTS@(2)=$P(VADM(2),U,2) 105 S @RESULTS@(3)=$P(VADM(3),U,2) 106 S @RESULTS@(4)=VADM(4) 107 S @RESULTS@(5)=$P(VADM(5),U,2) 108 I VAIN(4)]"" S @RESULTS@(6)="Ward: "_$P(VAIN(4),U,2)_" Rm: "_VAIN(5) 109 E S @RESULTS@(6)="" 110 Q 111 ; 112 GETRES ; [Procedure] Get results report 113 F MDX=0:0 S MDX=$O(^MDD(703.1,"ADFN",DFN,MDX)) Q:'MDX D 114 .S MDINST=+$P($G(^MDD(703.1,MDX,0)),U,4) 115 .I $G(DATA) Q:'$D(^MDS(702.01,DATA,.1,"B",MDINST)) 116 .S MDY=$O(@RESULTS@(""),-1)+1 117 .S @RESULTS@(MDY)="703.1;"_MDX_U_^MDD(703.1,MDX,0) 118 .S Y=$P(^MDD(703.1,MDX,0),U,3) D D^DIQ 119 .S $P(@RESULTS@(MDY),U,11)=Y 120 .S Y=$P($G(^MDS(702.09,+$P(^MDD(703.1,MDX,0),U,4),0)),U) 121 .S $P(@RESULTS@(MDY),U,12)=Y 122 S @RESULTS@(0)=+$O(@RESULTS@(""),-1) 123 Q 124 ; 125 GETTRAN ; [Procedure] Get a patients transactions 126 K ^TMP("MDTMP",$J),^TMP("MDCONL",$J) N MDCDT,MDCOM,MDMULT,MDNUM,MDREQ,MDREQDT,MDYR,X1,X2,X 127 S MDNUM=$$GET^XPAR("SYS","MD DAYS TO RETAIN COM STUDY",1) S MDCOM=0 128 I +MDNUM>0 S X1=DT,X2=-MDNUM D C^%DTC S MDCOM=X 129 D CPLIST^GMRCCP(DFN,,$NA(^TMP("MDTMP",$J))) 130 S X1=DT,X2=-365 D C^%DTC S MDCDT=X 131 S MDX=0 F S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX D:"saprc"[$P(^(MDX),U,4) 132 .I $P($G(^TMP("MDTMP",$J,MDX)),U,4)="c" Q:$P($G(^TMP("MDTMP",$J,MDX)),U,1)<MDCDT 133 .S ^TMP("MDCONL",$J,$P($G(^TMP("MDTMP",$J,MDX)),U,5))=$P($G(^TMP("MDTMP",$J,MDX)),U,1) 134 K ^TMP("MDTMP",$J) 135 F MDX=0:0 S MDX=$O(^MDD(702,"B",DFN,+MDX))_"," Q:'MDX D 136 .Q:'$$GET1^DIQ(702,MDX,.05,"I") 137 .Q:$G(^TMP("MDCONL",$J,+$$GET1^DIQ(702,MDX,.05,"I")))="" 138 .S MDMULT=+$$GET1^DIQ(702,MDX,".04:.12","I") 139 .S MDYR=$S(MDMULT<1:MDCOM,1:MDCDT) 140 .I MDNUM Q:$$GET1^DIQ(702,MDX,.09,"I")=3&($$GET1^DIQ(702,MDX,.02,"I")<MDYR) 141 .S MDREQDT="" I +$$GET1^DIQ(702,MDX,.05,"I") S MDREQDT=$G(^TMP("MDCONL",$J,+$$GET1^DIQ(702,MDX,.05,"I"))) 142 .I MDREQDT'="" S MDREQDT=$$FMTE^XLFDT(MDREQDT,"1P") 143 .S MDREQ=$$GET1^DIQ(702,MDX,.04)_" "_+MDX_" (Consult #:"_$$GET1^DIQ(702,MDX,.05,"I")_$S(MDREQDT'="":" Requested: "_MDREQDT,1:"")_")" 144 .S Z=$$GET1^DIQ(702,MDX,".04:.02","I")_U_MDREQ_U_$$GET1^DIQ(702,MDX,.02,"I")_U_$$GET1^DIQ(702,MDX,.09)_U_$$GET1^DIQ(702,MDX,.11)_U_$$GET1^DIQ(702,MDX,.991) 145 .S Y=$O(@RESULTS@(""),-1)+1 146 .S @RESULTS@(Y)="702;"_+MDX_U_Z 147 S @RESULTS@(0)=+$O(@RESULTS@(""),-1) 148 K ^TMP("MDCONL",$J) 149 Q 150 ; 151 GETVST ; [Procedure] Return list of visits 152 N BEG,END,VAERR,VASD,BDT,DTM,EDT,LOC,NOW,MDQUERY,MDLST,MDTDF,STI,STS,TODAY,I,J,K,XI,XE,X 153 S NOW=$$NOW^XLFDT(),TODAY=$P(NOW,".",1),MDTDF=DFN 154 S BEG=$$X2FM($$GETBEG),END=$$X2FM($$GETEND)+0.2359 155 S MDLST="",MDSTOP="" 156 I END>NOW D ; get future encounters, past cancels/no-shows from VADPT 157 .S VASD("F")=BEG 158 .S VASD("T")=END 159 .S VASD("W")="123456789" 160 .D SDA^VADPT 161 .S I=0 F S I=$O(^UTILITY("VASD",$J,I)) Q:'I D 162 ..S XI=^UTILITY("VASD",$J,I,"I"),XE=^("E") 163 ..S DTM=$P(XI,U),IEN=$P(XI,U,2),STI=$P(XI,U,3) 164 ..S LOC=$P(XE,U,2),STS=$P(XE,U,3) 165 ..I DTM<TODAY,(STI=""!(STI["I")!(STI="NT")) Q ; no prior kept appts 166 ..S MDLST(DTM,"A",1)="A;"_DTM_";"_IEN_U_DTM_U_LOC_U_STS 167 .K ^UTILITY("VASD",$J) 168 I BEG'>NOW D ;past encounters from ACRP Toolkit - set in CALLBACK 169 .S BDT=BEG 170 .S EDT=$S(END<NOW:END,1:NOW) 171 .D OPEN^SDQ(.MDQUERY) 172 .I '$$ERRCHK^SDQUT() D INDEX^SDQ(.MDQUERY,"PATIENT/DATE","SET") 173 .I '$$ERRCHK^SDQUT() D PAT^SDQ(.MDQUERY,DFN,"SET") 174 .I '$$ERRCHK^SDQUT() D DATE^SDQ(.MDQUERY,BDT,EDT,"SET") 175 .I '$$ERRCHK^SDQUT() D 176 ..D SCANCB^SDQ(.MDQUERY,"D CALLBACK^ORWCV(Y,Y0,$NA(MDLST),.MDSTOP)","SET") 177 .I '$$ERRCHK^SDQUT() D ACTIVE^SDQ(.MDQUERY,"TRUE","SET") 178 .I '$$ERRCHK^SDQUT() D SCAN^SDQ(.MDQUERY,"FORWARD") 179 .D CLOSE^SDQ(.MDQUERY) 180 N TIM,MOV,MDX0,Y,MTIM,XTYP,XLOC,XLOCI,HLOC,EARLY,DONE ; admits 181 S EARLY=BEG,DONE=0 S:$G(DFN)="" DFN=MDTDF 182 S TIM="" F S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0 D Q:DONE 183 .S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D Q:DONE 184 ..D GETS^DIQ(405,+MOV_",","*","IE","MDX0") S MTIM=$G(MDX0(405,MOV_",",".01","I")) 185 ..S XTYP=$G(MDX0(405,+MOV_",",".04","E")) 186 ..S XLOC=$G(MDX0(405,+MOV_",",".06","E")) 187 ..S XLOCI=+$G(MDX0(405,+MOV_",",".06","I")),HLOC=+$G(^DIC(42,+XLOCI,44)) 188 ..S MDLST(MTIM,"I",1)="I;"_MTIM_";"_HLOC_U_MTIM_U_"Inpatient Stay"_U_XLOC_U_XTYP 189 ..S DONE=1 ; Not sure if I should include all stays <DRP@Hines> 190 S I=0 F S I=$O(MDLST(I)) Q:'I D 191 .S J="" F S J=$O(MDLST(I,J)) Q:J="" D 192 ..S K=0 F S K=$O(MDLST(I,J,K)) Q:'K D 193 ...S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDLST(I,J,K) 194 S:$G(DFN)="" DFN=MDTDF S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_U_($$GET1^DIQ(2,DFN_",",.1)]"") 195 Q 196 ; 197 GETBEG() ; Get Beginning Date Range 198 I $$GET^XPAR("SYS","MD APPOINT START DATE",1)>1 Q "T-"_$$GET^XPAR("SYS","MD APPOINT START DATE",1) 199 Q "T-200" 200 GETEND() ; Get Ending Date Range 201 I $$GET^XPAR("SYS","MD APPOINT END DATE",1)>1 Q "T+"_$$GET^XPAR("SYS","MD APPOINT END DATE",1) 202 Q "T" 203 LOGSEC ; [Procedure] Log Security 204 N RES 205 D NOTICE^DGSEC4(.RES,DFN,DATA,1) 206 S @RESULTS@(0)=$S(+RES:"1^Logged",1:"-1^Unable to log") 207 Q 208 ; 209 RPC(RESULTS,OPTION,DFN,DATA) ; [Procedure] Main RPC call tag 210 NEW DFNIENS,GMRAL,GMVALG,GN,IENS,MDDFN,MDERR,MDFDA,MDFLD,MDHL7,MDID,MDIDS,MDIEN,MDIENS,MDRET,MDX,MDY,VA,VADM,VAERR,VAIN,Z 211 S RESULTS=$NA(^TMP($J)) K @RESULTS 212 D:$T(@OPTION)]"" @OPTION 213 D:'$D(@RESULTS) BADRPC^MDRPCU("MD TMDPATIENT","MDRPCOP",OPTION) 214 D CLEAN^DILF 215 Q 216 ; 217 SELECT ; [Procedure] Select patient 218 ; Moved to continuation routine at MD*1.0*6 due to routine size 219 D SELECT^MDRPCOP1 220 Q 221 ; 222 X2FM(X) ; [Function] return FM date given relative date 223 N %DT S %DT="TS" D ^%DT 224 Q Y 225 ; 1 MDRPCOP ; HOIFO/DP - Object RPCs (TMDPatient) ; [01-09-2003 15:21] 2 ;;1.0;CLINICAL PROCEDURES;**4**;Apr 01, 2004;Build 3 3 ; Integration Agreements: 4 ; IA# 3027 [Supported] Calls to DGSEC4 5 ; IA# 2981 [Subscription] Calls to GUI~GMRCP5 6 ; IA# 2548 [Supported] ACRP Interface Toolkit APIs. 7 ; IA# 2552 [Supported] AIT API to provide outpatient encounter data. 8 ; IA# 10061 [Supported] VADPT calls. 9 ; IA# 3468 [Subscription] Use GMRCCP APIs. 10 ; IA# 3266 [Subscription] Call to DPTLK1 11 ; IA# 10103 [Supported] Call to XLFDT 12 ; IA# 10039 [Supported] Ward Location File (#42) Access. 13 ; IA# 10035 [Supported] DPT references 14 ; IA# 3267 [Subscription] Call to DPTLK1 15 ; IA# 3593 [Supported] Access to routine DPTLK6 utilities for lookup 16 ; IA# 3613 [Private] GETVST^MDRPCOP API call 17 ; IA# 10099 [Supported] GMRADPT call 18 ; IA# 1096 [Controlled Subscription] ^DGPM("ATID1" x-ref loop 19 ; 20 ADD(X) ; [Procedure] Add line to @RESULTS@(... 21 S @RESULTS@(+$O(@RESULTS@(""),-1)+1)=X 22 Q 23 ; 24 ALLERGY ; [Procedure] Return Allergies 25 D EN1^GMRADPT I '$O(GMRAL(0)) D Q 26 .I $G(GMRAL)="" S @RESULTS@(0)="No Allergy Assessment" 27 .I $G(GMRAL)=0 S @RESULTS@(0)="No Known Allergies" 28 S @RESULTS@(0)="This patient has the following allergy(ies): " 29 F X=0:0 S X=$O(GMRAL(X)) Q:'X D 30 .S @RESULTS@(X)=$P($G(GMRAL(X)),U,2) 31 Q 32 ; 33 CHKIN ; [Procedure] Check In Study 34 F X=2:1:5 D 35 .I $P(DATA,U,X)]"" S MDFDA(702,$P(DATA,U,1),$P("^.04^.05^.11^.07",U,X))=$P(DATA,U,X) 36 S MDFDA(702,$P(DATA,U,1),.09)=4 ; Status = Checked-In 37 I $P(DATA,U,1)="+1," D 38 .S MDFDA(702,"+1,",.01)=DFN 39 .S MDFDA(702,"+1,",.02)=$$NOW^XLFDT() 40 .S MDFDA(702,"+1,",.03)=DUZ 41 .D UPDATE^DIE("","MDFDA","MDIEN","MDERR") Q:$D(MDERR) 42 .S MDIENS=MDIEN(1)_",",MDHL7=$$SUB^MDHL7B(MDIEN(1)) 43 .I +MDHL7=-1 S MDFDA(702,MDIENS,.09)=2,MDFDA(702,MDIENS,.08)=$P(MDHL7,U,2) 44 .I +MDHL7=1 S MDFDA(702,MDIENS,.09)=5,MDFDA(702,MDIENS,.08)="" 45 .D:$D(MDFDA) FILE^DIE("","MDFDA","MDERR") 46 I $P(DATA,U,1)'="+1," D 47 .D FILE^DIE("","MDFDA","MDERR") Q:$D(MDERR) 48 .S MDIENS=+DATA_"," 49 .S MDHL7=$$SUB^MDHL7B(+MDIENS) 50 .I +MDHL7=-1 S MDFDA(702,MDIENS,.09)=2,MDFDA(702,MDIENS,.08)=$P(MDHL7,U,2) 51 .I +MDHL7=1 S MDFDA(702,MDIENS,.09)=5,MDFDA(702,MDIENS,.08)="" 52 .D:$D(MDFDA) FILE^DIE("","MDFDA","MDERR") 53 I '$D(MDERR) S @RESULTS@(0)="1^OK" Q 54 D ERROR^MDRPCU(RESULTS,.MDERR) 55 Q 56 ; 57 DISPCON ; [Procedure] Display a consult 58 K ^TMP("GMRC",$J) 59 D GUI^GMRCP5(.RESULTS,DATA) 60 Q 61 ; 62 GETCONS ; [Procedure] Get available consults for patient 63 K ^TMP("MDTMP",$J) 64 D CPLIST^GMRCCP(DFN,,$NA(^TMP("MDTMP",$J))) 65 S MDX=0 66 F S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX D:"saprc"[$P(^(MDX),U,4) 67 .S Y="123;"_$P(^TMP("MDTMP",$J,MDX),U,5) 68 .F X=2,3,4,1,6,5 S Y=Y_U_$P(^TMP("MDTMP",$J,MDX),U,X) 69 .S Y=Y_U_+$O(^MDD(702,"ACON",+$P(^TMP("MDTMP",$J,MDX),U,5))) 70 .; 71 .; Patch MD*1.0*4 - Return number of times checked in at piece 9 72 .; 73 .S (X,Z)=0,MDY=+$P(^TMP("MDTMP",$J,MDX),U,5) 74 .F S X=$O(^MDD(702,"ACON",MDY,X)) Q:'X S Z=Z+1 75 .S $P(Y,U,9)=Z 76 .; 77 .; End Patch MD*1.0*4 78 .; 79 .D ADD(Y) 80 S @RESULTS@(0)=+$O(@RESULTS@(""),-1) 81 K ^TMP("MDTMP",$J) 82 Q 83 ; 84 GETHDR ; [Procedure] Get Pt Header 85 S DFNIENS=DFN_"," 86 S @RESULTS@(0)=$$GET1^DIQ(2,DFNIENS,.01)_" "_$$GET1^DIQ(2,DFNIENS,.1)_" "_$$GET1^DIQ(2,DFNIENS,.101) 87 S @RESULTS@(1)=$$GET1^DIQ(2,DFNIENS,.09)_" "_$$GET1^DIQ(2,DFNIENS,.02)_" "_$$GET1^DIQ(2,DFNIENS,.03)_" ("_$$GET1^DIQ(2,DFNIENS,.033)_")" 88 Q 89 ; 90 GETOBJ ; [Procedure] Get information for TMDPATIENT object 91 D DEM^VADPT,INP^VADPT 92 S @RESULTS@(0)=DFN 93 S @RESULTS@(1)=VADM(1) 94 S @RESULTS@(2)=$P(VADM(2),U,2) 95 S @RESULTS@(3)=$P(VADM(3),U,2) 96 S @RESULTS@(4)=VADM(4) 97 S @RESULTS@(5)=$P(VADM(5),U,2) 98 I VAIN(4)]"" S @RESULTS@(6)="Ward: "_$P(VAIN(4),U,2)_" Rm: "_VAIN(5) 99 E S @RESULTS@(6)="" 100 Q 101 ; 102 GETRES ; [Procedure] Get results report 103 F MDX=0:0 S MDX=$O(^MDD(703.1,"ADFN",DFN,MDX)) Q:'MDX D 104 .S MDINST=+$P($G(^MDD(703.1,MDX,0)),U,4) 105 .I $G(DATA) Q:'$D(^MDS(702.01,DATA,.1,"B",MDINST)) 106 .S MDY=$O(@RESULTS@(""),-1)+1 107 .S @RESULTS@(MDY)="703.1;"_MDX_U_^MDD(703.1,MDX,0) 108 .S Y=$P(^MDD(703.1,MDX,0),U,3) D D^DIQ 109 .S $P(@RESULTS@(MDY),U,11)=Y 110 .S Y=$P($G(^MDS(702.09,+$P(^MDD(703.1,MDX,0),U,4),0)),U) 111 .S $P(@RESULTS@(MDY),U,12)=Y 112 S @RESULTS@(0)=+$O(@RESULTS@(""),-1) 113 Q 114 ; 115 GETTRAN ; [Procedure] Get a patients transactions 116 F MDX=0:0 S MDX=$O(^MDD(702,"B",DFN,+MDX))_"," Q:'MDX D 117 .S Z=$$GET1^DIQ(702,MDX,".04:.02","I")_U_$$GET1^DIQ(702,MDX,.04)_U_$$GET1^DIQ(702,MDX,.02,"I")_U_$$GET1^DIQ(702,MDX,.09)_U_$$GET1^DIQ(702,MDX,.11)_U_$$GET1^DIQ(702,MDX,.991) 118 .S Y=$O(@RESULTS@(""),-1)+1 119 .S @RESULTS@(Y)="702;"_+MDX_U_Z 120 S @RESULTS@(0)=+$O(@RESULTS@(""),-1) 121 Q 122 ; 123 GETVST ; [Procedure] Return list of visits 124 N BEG,END,VAERR,VASD,BDT,DTM,EDT,LOC,NOW,MDQUERY,MDLST,STI,STS,TODAY,I,J,K,XI,XE,X 125 S NOW=$$NOW^XLFDT(),TODAY=$P(NOW,".",1) 126 S BEG=$$X2FM("T-200"),END=$$X2FM("T")+0.2359 127 S MDLST="",MDSTOP="" 128 I END>NOW D ; get future encounters, past cancels/no-shows from VADPT 129 .S VASD("F")=BEG 130 .S VASD("T")=END 131 .S VASD("W")="123456789" 132 .D SDA^VADPT 133 .S I=0 F S I=$O(^UTILITY("VASD",$J,I)) Q:'I D 134 ..S XI=^UTILITY("VASD",$J,I,"I"),XE=^("E") 135 ..S DTM=$P(XI,U),IEN=$P(XI,U,2),STI=$P(XI,U,3) 136 ..S LOC=$P(XE,U,2),STS=$P(XE,U,3) 137 ..I DTM<TODAY,(STI=""!(STI["I")!(STI="NT")) Q ; no prior kept appts 138 ..S MDLST(DTM,"A",1)="A;"_DTM_";"_IEN_U_DTM_U_LOC_U_STS 139 .K ^UTILITY("VASD",$J) 140 I BEG'>NOW D ;past encounters from ACRP Toolkit - set in CALLBACK 141 .S BDT=BEG 142 .S EDT=$S(END<NOW:END,1:NOW) 143 .D OPEN^SDQ(.MDQUERY) 144 .I '$$ERRCHK^SDQUT() D INDEX^SDQ(.MDQUERY,"PATIENT/DATE","SET") 145 .I '$$ERRCHK^SDQUT() D PAT^SDQ(.MDQUERY,DFN,"SET") 146 .I '$$ERRCHK^SDQUT() D DATE^SDQ(.MDQUERY,BDT,EDT,"SET") 147 .I '$$ERRCHK^SDQUT() D 148 ..D SCANCB^SDQ(.MDQUERY,"D CALLBACK^ORWCV(Y,Y0,$NA(MDLST),.MDSTOP)","SET") 149 .I '$$ERRCHK^SDQUT() D ACTIVE^SDQ(.MDQUERY,"TRUE","SET") 150 .I '$$ERRCHK^SDQUT() D SCAN^SDQ(.MDQUERY,"FORWARD") 151 .D CLOSE^SDQ(.MDQUERY) 152 N TIM,MOV,MDX0,Y,MTIM,XTYP,XLOC,XLOCI,HLOC,EARLY,DONE ; admits 153 S EARLY=BEG,DONE=0 154 S TIM="" F S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0 D Q:DONE 155 .S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D Q:DONE 156 ..D GETS^DIQ(405,+MOV_",","*","IE","MDX0") S MTIM=$G(MDX0(405,MOV_",",".01","I")) 157 ..S XTYP=$G(MDX0(405,+MOV_",",".04","E")) 158 ..S XLOC=$G(MDX0(405,+MOV_",",".06","E")) 159 ..S XLOCI=+$G(MDX0(405,+MOV_",",".06","I")),HLOC=+$G(^DIC(42,+XLOCI,44)) 160 ..S MDLST(MTIM,"I",1)="I;"_MTIM_";"_HLOC_U_MTIM_U_"Inpatient Stay"_U_XLOC_U_XTYP 161 ..S DONE=1 ; Not sure if I should include all stays <DRP@Hines> 162 S I=0 F S I=$O(MDLST(I)) Q:'I D 163 .S J="" F S J=$O(MDLST(I,J)) Q:J="" D 164 ..S K=0 F S K=$O(MDLST(I,J,K)) Q:'K D 165 ...S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDLST(I,J,K) 166 S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_U_($$GET1^DIQ(2,DFN_",",.1)]"") 167 Q 168 ; 169 LOGSEC ; [Procedure] Log Security 170 D NOTICE^DGSEC4(.RESULTS,DFN,DATA,1) 171 S @RESULTS@(0)=$S(RESULTS:"1^Logged",1:"-1^Unable to log") 172 Q 173 ; 174 RPC(RESULTS,OPTION,DFN,DATA) ; [Procedure] Main RPC call tag 175 NEW DFNIENS,GMRAL,GMVALG,GN,IENS,MDDFN,MDERR,MDFDA,MDFLD,MDHL7,MDID,MDIDS,MDIEN,MDIENS,MDRET,MDX,MDY,VA,VADM,VAERR,VAIN,Z 176 S RESULTS=$NA(^TMP($J)) K @RESULTS 177 D:$T(@OPTION)]"" @OPTION 178 D:'$D(@RESULTS) BADRPC^MDRPCU("MD TMDPATIENT","MDRPCOP",OPTION) 179 D CLEAN^DILF 180 Q 181 ; 182 SELECT ; [Procedure] Select patient 183 I '$D(^DPT(+$G(DFN),0))#2 S @RESULTS@(0)="-1^No such patient" Q 184 S @RESULTS@(0)="1^Required Identifiers & messages" 185 S IENS=DFN_"," 186 D FILE^DID(2,,"REQUIRED IDENTIFIERS","MDIDS") 187 F MDX=0:0 S MDX=$O(MDIDS("REQUIRED IDENTIFIERS",MDX)) Q:'MDX D 188 .S MDFLD=MDIDS("REQUIRED IDENTIFIERS",MDX,"FIELD") 189 .S MDID="$$PTID^"_$$GET1^DID(2,MDFLD,"","LABEL") 190 .S MDID=MDID_U_$$GET1^DIQ(2,IENS,MDFLD) 191 .D:MDFLD=.03 192 ..S MDID=MDID_" ("_$$GET1^DIQ(2,IENS,.033)_")" 193 ..S MDID=MDID_U_$$DOB^DPTLK1(+IENS) 194 .D:MDFLD=.09 195 ..S X=$P(MDID,U,3),X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10) 196 ..S $P(MDID,U,3)=X,$P(MDID,U,4)=$$SSN^DPTLK1(+IENS) 197 .S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDID 198 S MDID="$$PTID^"_$$GET1^DID(2,.1,"","LABEL") 199 S MDID=MDID_U_$$GET1^DIQ(2,IENS,.1) 200 S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDID 201 S MDID="$$PTID^"_$$GET1^DID(2,.101,"","LABEL") 202 S MDID=MDID_U_$$GET1^DIQ(2,IENS,.101) 203 S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDID 204 K MDRET 205 D GUIBS5A^DPTLK6(.MDRET,DFN) D:MDRET(1)=1 206 .D ADD("$$MSGHDR^2^SAME LAST NAME AND LAST 4") 207 .S MDX=1 208 .F S MDX=$O(MDRET(MDX)) Q:'MDX!(+$G(MDRET(MDX))) D 209 ..D ADD($P(MDRET(MDX),U,2)) 210 .D ADD(" ") 211 .S MDX=1 212 .F S MDX=$O(MDRET(MDX)) Q:'MDX D:+MDRET(MDX) 213 ..S MDDFN=+$P(MDRET(MDX),U,2) 214 ..D ADD($$GET1^DIQ(2,MDDFN_",",.01)_" "_$$DOB^DPTLK1(MDDFN)_" "_$$SSN^DPTLK1(MDDFN)) 215 .D ADD(" ") 216 .D ADD("Please review carefully before continuing") 217 .D ADD("$$MSGEND") 218 K MDRET 219 D PTSEC^DGSEC4(.MDRET,DFN) D:MDRET(1)'=0 220 .D:MDRET(1)=3 221 ..D ADD("$$MSGHDR^0^CAN'T ACCESS YOUR OWN RECORD!!") 222 .D:MDRET(1)=-1 223 ..D ADD("$$MSGHDR^0^INCOMPLETE INFORMATION - CAN'T PROCEED") 224 .D:MDRET(1)=1 225 ..D ADD("$$MSGHDR^1^SENSITIVE RECORD ACCESS") 226 .D:MDRET(1)'=-1&(MDRET(1)'=3)&(MDRET(1)'=1) 227 ..D ADD("$$MSGHDR^3^SENSITIVE RECORD ACCESS") 228 .S MDX=1 229 .F S MDX=$O(MDRET(MDX)) Q:'MDX D ADD($TR(MDRET(MDX),"*"," ")) 230 .D ADD("$$MSGEND") 231 D GUIMTD^DPTLK6(.MDRET,DFN) D:MDRET(1)=1 232 .D ADD("$$MSGHDR^1^NOTICE") 233 .F MDX=1:0 S MDX=$O(MDRET(MDX)) Q:'MDX D ADD(MDRET(MDX)) 234 .D ADD("$$MSGEND") 235 Q 236 ; 237 X2FM(X) ; [Function] return FM date given relative date 238 N %DT S %DT="TS" D ^%DT 239 Q Y 240 ; -
WorldVistAEHR/trunk/r/CLINICAL_PROCEDURES-MD/MDRPCOT.m
r613 r623 1 MDRPCOT ; HOIFO/DP/NCA - Object RPCs (TMDTransaction) ;3/12/08 09:18 2 ;;1.0;CLINICAL PROCEDURES;**5,6**;Apr 01, 2004;Build 102 3 ; Integration Agreements: 4 ; IA# 2693 [Subscription] TIU Extractions. 5 ; IA# 2944 [Subscription] Calls to TIUSRVR1. 6 ; IA# 3535 [Subscription] Calls to TIUSRVP. 7 ; IA# 10104 [Supported] Routine XLFSTR calls 8 ADDMSG ; [Procedure] Add message to transaction 9 N MDIEN,MDIENS,MDRET 10 Q:'$G(DATA("TRANSACTION")) 11 Q:$G(DATA("MESSAGE"))="" 12 S MDIEN=+DATA("TRANSACTION"),MDIENS="+1,"_MDIEN_"," 13 D NOW^%DTC S DATA("DATE")=% K % 14 S MDFDA(702.091,MDIENS,.01)=+$O(^MDD(702,+MDIEN,.091,"A"),-1)+1 15 S MDFDA(702.091,MDIENS,.02)=DATA("DATE") 16 S MDFDA(702.091,MDIENS,.03)=$G(DATA("PKG"),"UNKNOWN") 17 S MDFDA(702.091,MDIENS,.09)=DATA("MESSAGE") 18 D UPDATE^DIE("","MDFDA","MDRET") 19 Q 20 ; 21 DELETE ; [Procedure] Delete Study 22 ; Sets @RESULTS@(0)="-1^Reason for not deleting" or "1^Study Deleted" 23 ; 24 N MDAST,MDHOLD,MDNOTE,MDRES,MDSIEN,BODY,SUBJECT,DEVIEN 25 S (MDHOLD,MDSIEN)=+DATA,MDRES=0,MDNOTE="" 26 D ALERT^MDHL7U3(MDSIEN) ; Builds the body of the mail message 27 I $G(^MDD(702,+MDSIEN,0))="" S @RESULTS@(0)="1^Study Deleted." D NOTICE^MDHL7U3(SUBJECT,.BODY,DEVIEN,DUZ) Q ;deleting message 28 S:+$P(^MDD(702,MDSIEN,0),U,6) MDNOTE=$P(^MDD(702,MDSIEN,0),U,6) 29 I "13"[$P(^MDD(702,MDSIEN,0),U,9) S @RESULTS@(0)="-1^Can't Delete TIU Note from a "_$$GET1^DIQ(702,MDSIEN,.09,"E")_" Study." Q 30 I "5"[$P(^MDD(702,MDSIEN,0),U,9) S MDCANR=$$CANCEL^MDHL7B(MDHOLD) I MDCANR<1 S @RESULTS@(0)="-1^"_$P(MDCANR,"^",2) Q 31 I +MDNOTE S MDRES="" D DELETE^TIUSRVP(.MDRES,MDNOTE) 32 I MDRES D Q 33 .D STATUS(MDSIEN_",",2,$P(MDRES,"^",2)) 34 .S DATA("TRANSACTION")=MDSIEN,DATA("PKG")="TIU" 35 .S DATA("MESSAGE")=$P(MDRES,"^",2) D ADDMSG 36 .S @RESULTS@(0)="-1^"_$P(MDRES,"^",2) 37 .Q 38 E D 39 .I $D(^MDD(702.001,"ASTUDY",MDSIEN)) S @RESULTS@(0)="-1^Note associated with study, can not delete." Q 40 .S MDAST=$$HL7CHK^MDHL7U3(+MDSIEN) I +MDAST<1 S @RESULTS@(0)=MDAST Q 41 .D NOTICE^MDHL7U3(SUBJECT,.BODY,DEVIEN,DUZ) ; delete message 42 .S MDFDA(702,DATA_",",.01)="" 43 .; Check for renal study to delete as well 44 .S:$D(^MDK(704.202,DATA)) MDFDA(704.202,DATA_",",.01)="" 45 .D FILE^DIE("","MDFDA") 46 .N DA,DIK S DA=+MDSIEN,DIK="^MDD(702," D ^DIK 47 .S @RESULTS@(0)="1^Study Deleted." 48 .Q 49 Q 50 ; 51 FILEMSG(STUDY,MDPKG,MDSTAT,MDMSG) ; [Procedure] File Study Status and Message. 52 S DATA("TRANSACTION")=STUDY,DATA("PKG")=MDPKG 53 S DATA("MESSAGE")=$P(MDMSG,"^",2) 54 D STATUS(STUDY_",",MDSTAT,$P(MDMSG,"^",2)),ADDMSG 55 Q 56 ; 57 FILES ; [Procedure] Add/remove an attachment to this transaction 58 NEW MDFDA,MDIEN,MDIENS,MDRET,P1,P2,P3,P4 59 S P1=$P(DATA,U,1),P2=$P(DATA,U,2),P3=$P(DATA,U,3),P4=$P(DATA,U,4) 60 S MDIEN=0 I $G(^MDD(702,+P1,0))="" Q 61 ; Look for file (All comparisons done on lower case values) 62 F S MDIEN=$O(^MDD(702,P1,.1,MDIEN)) Q:'MDIEN D Q:X=P3 63 .S X=$$LOW^XLFSTR($G(^MDD(702,P1,.1,MDIEN,.1))) 64 I MDIEN&P4 S @RESULTS@(0)="1^File already assigned" Q 65 I 'MDIEN&'P4 S @RESULTS@(0)="1^File not assigned" Q 66 I P4 D Q ; Add a file 67 .S MDIENS="+1,"_P1_"," 68 .S MDFDA(702.1,MDIENS,.01)=$O(^MDD(702,P1,.1,"B",""),-1)+1 69 .S MDFDA(702.1,MDIENS,.02)=$S(P2:"I",1:"U") 70 .I P2 S MDFDA(702.1,MDIENS,.03)=P2 71 .S MDFDA(702.1,MDIENS,.1)=P3 72 .D UPDATE^DIE("","MDFDA","MDIEN") 73 .S @RESULTS@(0)=+$G(MDIEN(1),-1) 74 I 'P4 D Q ; Remove the file 75 .S MDFDA(702.1,MDIEN_","_P1_",",.01)="@" 76 .D FILE^DIE("","MDFDA","MDRET") 77 .S @RESULTS@(0)=$S($D(MDRET):-1,1:1) 78 Q 79 ; 80 GETATT ; [Procedure] Get Attachments 81 F X=0:0 S X=$O(^MDD(702,DATA,.1,X)) Q:'X D 82 .S Y=$O(@RESULTS@(""),-1)+1 83 .S @RESULTS@(Y)=$P(^MDD(702,DATA,.1,X,0),U,1,3) 84 .S $P(@RESULTS@(Y),U,4)=$G(^MDD(702,DATA,.1,X,.1)) 85 S @RESULTS@(0)=+$O(@RESULTS@(""),-1) 86 Q 87 ; 88 GETERR ; [Procedure] Return list of Imaging Errors 89 ; DATA = Transaction IEN 90 F MDX=0:0 S MDX=$O(^MDD(702,DATA,.091,MDX)) Q:'MDX D 91 .S MDY=+^MDD(702,DATA,.091,MDX,0)_U,Y=$P(^(0),U,2) 92 .D D^DIQ S MDY=MDY_Y_U 93 .S MDY=MDY_$P(^MDD(702,DATA,.091,MDX,0),U,3)_U_$P(^(0),U,9) 94 .S ^TMP($J,$O(^TMP($J,""),-1)+1)=MDY 95 S ^TMP($J,0)=+$O(^TMP($J,""),-1) 96 Q 97 ; 98 NEWSTAT ; [Procedure] RPC Call to set status 99 S MDFDA(702,DATA,.09)=TYPE 100 D FILE^DIE("","MDFDA") 101 I TYPE=3&($G(^MDK(704.202,+DATA,0))'="") K MDFDA S MDFDA(704.202,DATA,.09)=0 D FILE^DIE("","MDFDA") K MDFDA 102 Q 103 ; 104 RPC(RESULTS,OPTION,DATA,TYPE,FILE,RESREP) ; [Procedure] Main RPC call 105 N MDCANR,MDCON,MDDOC,MDFDA,MDFN,MDGST,MDHOLD,MDIEN,MDIENS,MDL,MDLOC,MDMSG,MDNEWV,MDNOTE,MDNVST,MDPDT,MDPKG,MDPROC,MDRES,MDRESU,MDRESUL,MDRET,MDS,MDSIEN,MDSTAT,MDSTUDY,MDTITL,MDTIUER,MDTRAN,MDTST,MDTSTR,MDVST,MDVSTR,MDWP,MDX,MDY 106 S RESULTS=$NA(^TMP($J)) K @RESULTS 107 D:$T(@OPTION)]"" @OPTION 108 D:'$D(@RESULTS) BADRPC^MDRPCU("MD TMDTRANSACTION","MDRPCOT",OPTION) 109 D CLEAN^DILF 110 Q 111 ; 112 STATUS(MDIENS,MDSTAT,MDMSG) ; [Procedure] Update transaction status 113 S MDFDA(702,MDIENS,.08)=$G(MDMSG) 114 S MDFDA(702,MDIENS,.09)=MDSTAT 115 D FILE^DIE("","MDFDA") 116 Q 117 ; 118 SUBMIT ; [Procedure] Process the Image(s) Submission. 119 ; Output: -1^Error Message or 120 ; 1^Successful Message 121 N MDRESUL,MDSTUDY 122 S MDSTUDY=+DATA,MDRESUL="" 123 ; Create New TIU Document 124 S MDRESUL=$$NEWTIUN(MDSTUDY) 125 ; File TIU Error messages 126 I +MDRESUL<0 D Q 127 .D FILEMSG(MDSTUDY,"TIU",2,MDRESUL) 128 .S @RESULTS@(0)=MDRESUL 129 ; Submit and export the images 130 S MDRESUL=$$SUBMIT^MDRPCOT1(MDSTUDY) 131 ; File message 132 D FILEMSG(MDSTUDY,"IMAGING",$S(+MDRESUL>0:+MDRESUL,1:2),MDRESUL) 133 S @RESULTS@(0)=MDRESUL 134 Q 135 ; 136 VIEWTIU ; [Procedure] VIew the associated tiu document 137 I '$P(^MDD(702,+DATA,0),U,6) D Q 138 .S @RESULTS@(0)="NO TIU NOTE FOR THIS STUDY" 139 D TGET^TIUSRVR1(.RESULTS,+$P(^MDD(702,+DATA,0),U,6)) 140 Q 141 ; 142 GETDATA(STUDY) ; [Function] Return the Necessary data for creating a TIU note. 143 ; Return: Patient DFN_"^"_TIU title_"^"_Hospital Location_"^"_TIU Note 144 ; IEN_"^"_Consult #_"^"_CP Definition IEN_"^"_Visit String_"^" 145 ; New Visit Flag 146 ; or 147 ; -1^Error Message 148 N DFN,MDCON,MDFN,MDIEN,MDIENS,MDLOC,MDNEWV,MDNOTE,MDNVST,MDPROC,MDVSTR,MDTITL,MDX,MDTST 149 S MDIEN=+STUDY,MDIENS=MDIEN_",",MDNVST=0 150 I $$GET1^DIQ(702,MDIENS,.01)="" Q "-1^No such study entry." 151 ; Get DFN 152 S DFN=$$GET1^DIQ(702,MDIEN,.01,"I") 153 I 'DFN Q "-1^No DFN." 154 ; Get CP Def 155 S MDPROC=$$GET1^DIQ(702,MDIEN,.04,"I") 156 I 'MDPROC Q "-1^No CP Def." 157 ; Get Consult 158 S MDCON=$$GET1^DIQ(702,MDIEN,.05,"I") 159 I 'MDCON Q "-1^No Consult #." 160 ; Get TIU Note Title 161 S MDTITL=$$GET1^DIQ(702.01,+MDPROC_",",.04,"I") 162 I 'MDTITL Q "-1^No TIU Note Title." 163 S MDVSTR=$$GET1^DIQ(702,MDIEN,.07) 164 I MDVSTR="" Q "-1^No Visit String." 165 I $L(MDVSTR,";")=1 S MDNVST=1,MDVSTR=";"_MDVSTR ; If new visit is selected 166 ; MDLOC is Hospital Location 167 I MDVSTR'="" D 168 .S MDVSTR=$$GETVSTR^MDRPCOT1(DFN,MDVSTR,MDPROC,$$GET1^DIQ(702,MDIEN,.02,"I")) 169 .S MDLOC=$P(MDVSTR,";",1) 170 I $$GET1^DIQ(702.01,+MDPROC_",",.12,"I")=1 Q DFN_"^"_MDTITL_"^"_MDLOC_"^^"_MDCON_"^"_MDPROC_"^"_MDVSTR_"^"_MDNVST 171 ; Does TIU doc already exist? 172 I $$GET1^DIQ(702,MDIEN,.06,"I") Q DFN_"^"_MDTITL_"^"_MDLOC_"^"_+$$GET1^DIQ(702,MDIEN,.06,"I")_"^"_MDCON_"^"_MDPROC_"^"_MDVSTR_"^"_MDNVST 173 ; Does TIU doc exist for previous transaction of this consult? 174 I MDCON S MDNOTE=$$PREV(MDCON,MDIEN) 175 Q DFN_"^"_MDTITL_"^"_MDLOC_"^"_+MDNOTE_"^"_MDCON_"^"_MDPROC_"^"_MDVSTR_"^"_MDNVST 176 ; 177 NEWTIUN(STUDY) ; [Function] Create a new TIU for transaction 178 ; Input: STUDY - IENS of CP study entry 179 ; Return: TIU Document IEN 180 N CTR,DFN,MDCON,MDFDA,MDGST,MDL,MDLOC,MDNOTE,MDPDT,MDPROC,MDRESU,MDTITL,MDTSTR,MDVST,MDVSTR,MDWP,MDPT S CTR=0,MDGST=+STUDY,MDRESU="" 181 ; Get data for TIU Note Creation 182 S (MDTSTR,MDRESU)=$$GETDATA(MDGST) 183 ; File Error message 184 I +MDRESU<0 D FILEMSG(MDGST,"CP",2,MDRESU) Q MDRESU 185 I $G(MDTSTR)="" Q "-1^No Data to Create TIU Document" 186 F MDL="DFN","MDTITL","MDLOC","MDNOTE","MDCON","MDPROC","MDVSTR","MDNVST" D 187 .S CTR=CTR+1,@MDL=$P(MDTSTR,"^",CTR) 188 S MDVST="" 189 ; If previous TIU document exists, quit 190 I MDNOTE Q MDNOTE 191 I 'MDLOC Q "-1^No Hospital Location." 192 ; Create new visit, if no vstring 193 S MDPDT=$$PDT^MDRPCOT1(MDGST) 194 I 'MDPDT S MDPT=$O(^MDD(703.1,"ASTUDYID",+MDGST,0)),MDPDT=$P($G(^MDD(703.1,+MDPT,0)),U,3) 195 S:'MDPDT MDPDT=$P(MDVSTR,";",2) ; If No D/T Performed grab visit D/T 196 I $P(MDVSTR,";",3)="V" S $P(MDVSTR,";",3)="A" 197 ; Build variables for TIU Call 198 S MDWP(.05)=1 ; Undicated Status 199 S MDWP(1405)=+MDCON_";GMR(123," ; Package Reference 200 S MDWP(70201)=5 ; Default Procedure Summary Code "Machine Resulted" 201 I MDPDT S MDWP(70202)=MDPDT ; Date/Time Performed 202 ; File PCE Error message 203 I MDNVST S MDRESU=$$EN1^MDPCE(MDGST,$P(MDVSTR,";",2),MDPROC,$P(MDVSTR,";",3),"P") I +MDRESU S MDVST=+MDRESU,MDVSTR=$P(MDRESU,"^",2) 204 I MDNVST&(+MDRESU<0) D FILEMSG(MDGST,"PCE",2,$P(MDRESU,"^",2)) Q MDRESU 205 ; Create the TIU note stub 206 S MDNOTE="" D MAKE^TIUSRVP(.MDNOTE,DFN,MDTITL,$P(MDVSTR,";",2),MDLOC,$S(MDVST:MDVST,1:""),.MDWP,MDVSTR,1,1) 207 I '(+MDNOTE) S $P(MDNOTE,"^")=-1 Q MDNOTE 208 ; Finalize the transaction 209 S MDFDA(702,STUDY_",",.06)=+MDNOTE 210 S MDFDA(702,STUDY_",",.08)="" 211 S:MDVST>0 MDFDA(702,STUDY_",",.13)=MDVST 212 D FILE^DIE("","MDFDA") 213 D UPD^MDKUTLR(STUDY,+MDNOTE) 214 Q 1 215 ; 216 PREV(MDC,MDS) ; [Function] Return the Previous TIU document. 217 N MDNEWV,MDDOC,MDTRAN,MDTIUER,MDTST 218 S (MDDOC,MDNEWV,MDTRAN,MDTIUER,MDTST)="" K ^TMP("MDTIUST",$J) 219 F S MDTRAN=$O(^MDD(702,"ACON",MDC,MDTRAN)) Q:'MDTRAN D Q:'MDTRAN 220 .I $P(^MDD(702,MDTRAN,0),U,6) D 221 ..D EXTRACT^TIULQ($P(^MDD(702,MDTRAN,0),U,6),"^TMP(""MDTIUST"",$J)",MDTIUER,".01;.05;1406") Q:+MDTIUER 222 ..S MDTST=$G(^TMP("MDTIUST",$J,$P(^MDD(702,MDTRAN,0),U,6),.05,"E")) 223 ..I MDTST'="UNDICTATED"&(MDTST'="UNSIGNED") K ^TMP("MDTIUST",$J) Q 224 ..I MDTST="UNSIGNED"&'($G(^TMP("MDTIUST",$J,$P(^MDD(702,MDTRAN,0),U,6),1406,"I"))) K ^TMP("MDTIUST",$J) Q 225 ..S MDDOC=$P(^MDD(702,MDTRAN,0),U,6),MDNEWV=$P(^MDD(702,MDTRAN,0),U,7) 226 ..Q:'MDS 227 ..S MDFDA(702,MDS_",",.06)=MDDOC 228 ..S MDFDA(702,MDS_",",.07)=MDNEWV 229 ..D FILE^DIE("","MDFDA") 230 ..S MDTRAN="" 231 Q MDDOC 232 ; 1 MDRPCOT ; HOIFO/DP/NCA - Object RPCs (TMDTransaction) ;12/5/02 15:33 2 ;;1.0;CLINICAL PROCEDURES;**5**;Apr 01, 2004;Build 1 3 ; Integration Agreements: 4 ; IA# 2693 [Subscription] TIU Extractions. 5 ; IA# 2944 [Subscription] Calls to TIUSRVR1. 6 ; IA# 3535 [Subscription] Calls to TIUSRVP. 7 ; IA# 10104 [Supported] Routine XLFSTR calls 8 ADDMSG ; [Procedure] Add message to transaction 9 N MDIEN,MDIENS,MDRET 10 Q:'$G(DATA("TRANSACTION")) 11 Q:$G(DATA("MESSAGE"))="" 12 S MDIEN=+DATA("TRANSACTION"),MDIENS="+1,"_MDIEN_"," 13 D NOW^%DTC S DATA("DATE")=% K % 14 S MDFDA(702.091,MDIENS,.01)=+$O(^MDD(702,+MDIEN,.091,"A"),-1)+1 15 S MDFDA(702.091,MDIENS,.02)=DATA("DATE") 16 S MDFDA(702.091,MDIENS,.03)=$G(DATA("PKG"),"UNKNOWN") 17 S MDFDA(702.091,MDIENS,.09)=DATA("MESSAGE") 18 D UPDATE^DIE("","MDFDA","MDRET") 19 Q 20 ; 21 DELETE ; [Procedure] Delete Study 22 ; Sets @RESULTS@(0)="-1^Reason for not deleting" or "1^Study Deleted" 23 ; 24 N MDHOLD,MDNOTE,MDRES,MDSIEN 25 S (MDHOLD,MDSIEN)=+DATA,MDRES=0,MDNOTE="" 26 S:+$P(^MDD(702,MDSIEN,0),U,6) MDNOTE=$P(^MDD(702,MDSIEN,0),U,6) 27 I "13"[$P(^MDD(702,MDSIEN,0),U,9) S @RESULTS@(0)="-1^Can't Delete TIU Note from a "_$$GET1^DIQ(702,MDSIEN,.09,"E")_" Study." Q 28 I "5"[$P(^MDD(702,MDSIEN,0),U,9) S MDCANR=$$CANCEL^MDHL7B(MDHOLD) I MDCANR<1 S @RESULTS@(0)="-1^"_$P(MDCANR,"^",2) Q 29 I +MDNOTE S MDRES="" D DELETE^TIUSRVP(.MDRES,MDNOTE) 30 I MDRES D Q 31 .D STATUS(MDSIEN_",",2,$P(MDRES,"^",2)) 32 .S DATA("TRANSACTION")=MDSIEN,DATA("PKG")="TIU" 33 .S DATA("MESSAGE")=$P(MDRES,"^",2) D ADDMSG 34 .S @RESULTS@(0)="-1^"_$P(MDRES,"^",2) 35 .Q 36 E D 37 .S MDFDA(702,DATA_",",.01)="" 38 .D FILE^DIE("","MDFDA") 39 .N DA,DIK S DA=+MDSIEN,DIK="^MDD(702," D ^DIK 40 .S @RESULTS@(0)="1^Study Deleted." 41 .Q 42 Q 43 ; 44 FILEMSG(STUDY,MDPKG,MDSTAT,MDMSG) ; [Procedure] File Study Status and Message. 45 S DATA("TRANSACTION")=STUDY,DATA("PKG")=MDPKG 46 S DATA("MESSAGE")=$P(MDMSG,"^",2) 47 D STATUS(STUDY_",",MDSTAT,$P(MDMSG,"^",2)),ADDMSG 48 Q 49 ; 50 FILES ; [Procedure] Add/remove an attachment to this transaction 51 NEW MDFDA,MDIEN,MDIENS,MDRET,P1,P2,P3,P4 52 S P1=$P(DATA,U,1),P2=$P(DATA,U,2),P3=$P(DATA,U,3),P4=$P(DATA,U,4) 53 S MDIEN=0 54 ; Look for file (All comparisons done on lower case values) 55 F S MDIEN=$O(^MDD(702,P1,.1,MDIEN)) Q:'MDIEN D Q:X=P3 56 .S X=$$LOW^XLFSTR($G(^MDD(702,P1,.1,MDIEN,.1))) 57 I MDIEN&P4 S @RESULTS@(0)="1^File already assigned" Q 58 I 'MDIEN&'P4 S @RESULTS@(0)="1^File not assigned" Q 59 I P4 D Q ; Add a file 60 .S MDIENS="+1,"_P1_"," 61 .S MDFDA(702.1,MDIENS,.01)=$O(^MDD(702,P1,.1,"B",""),-1)+1 62 .S MDFDA(702.1,MDIENS,.02)=$S(P2:"I",1:"U") 63 .I P2 S MDFDA(702.1,MDIENS,.03)=P2 64 .S MDFDA(702.1,MDIENS,.1)=P3 65 .D UPDATE^DIE("","MDFDA","MDIEN") 66 .S @RESULTS@(0)=+$G(MDIEN(1),-1) 67 I 'P4 D Q ; Remove the file 68 .S MDFDA(702.1,MDIEN_","_P1_",",.01)="@" 69 .D FILE^DIE("","MDFDA","MDRET") 70 .S @RESULTS@(0)=$S($D(MDRET):-1,1:1) 71 Q 72 ; 73 GETATT ; [Procedure] Get Attachments 74 F X=0:0 S X=$O(^MDD(702,DATA,.1,X)) Q:'X D 75 .S Y=$O(@RESULTS@(""),-1)+1 76 .S @RESULTS@(Y)=$P(^MDD(702,DATA,.1,X,0),U,1,3) 77 .S $P(@RESULTS@(Y),U,4)=$G(^MDD(702,DATA,.1,X,.1)) 78 S @RESULTS@(0)=+$O(@RESULTS@(""),-1) 79 Q 80 ; 81 GETERR ; [Procedure] Return list of Imaging Errors 82 ; DATA = Transaction IEN 83 F MDX=0:0 S MDX=$O(^MDD(702,DATA,.091,MDX)) Q:'MDX D 84 .S MDY=+^MDD(702,DATA,.091,MDX,0)_U,Y=$P(^(0),U,2) 85 .D D^DIQ S MDY=MDY_Y_U 86 .S MDY=MDY_$P(^MDD(702,DATA,.091,MDX,0),U,3)_U_$P(^(0),U,9) 87 .S ^TMP($J,$O(^TMP($J,""),-1)+1)=MDY 88 S ^TMP($J,0)=+$O(^TMP($J,""),-1) 89 Q 90 ; 91 NEWSTAT ; [Procedure] RPC Call to set status 92 S MDFDA(702,DATA,.09)=TYPE 93 D FILE^DIE("","MDFDA") 94 Q 95 ; 96 RPC(RESULTS,OPTION,DATA,TYPE,FILE,RESREP) ; [Procedure] Main RPC call 97 N MDCANR,MDCON,MDDOC,MDFDA,MDFN,MDGST,MDHOLD,MDIEN,MDIENS,MDL,MDLOC,MDMSG,MDNEWV,MDNOTE,MDNVST,MDPDT,MDPKG,MDPROC,MDRES,MDRESU,MDRESUL,MDRET,MDS,MDSIEN,MDSTAT,MDSTUDY,MDTITL,MDTIUER,MDTRAN,MDTST,MDTSTR,MDVST,MDVSTR,MDWP,MDX,MDY 98 S RESULTS=$NA(^TMP($J)) K @RESULTS 99 D:$T(@OPTION)]"" @OPTION 100 D:'$D(@RESULTS) BADRPC^MDRPCU("MD TMDTRANSACTION","MDRPCOT",OPTION) 101 D CLEAN^DILF 102 Q 103 ; 104 STATUS(MDIENS,MDSTAT,MDMSG) ; [Procedure] Update transaction status 105 S MDFDA(702,MDIENS,.08)=$G(MDMSG) 106 S MDFDA(702,MDIENS,.09)=MDSTAT 107 D FILE^DIE("","MDFDA") 108 Q 109 ; 110 SUBMIT ; [Procedure] Process the Image(s) Submission. 111 ; Output: -1^Error Message or 112 ; 1^Successful Message 113 N MDRESUL,MDSTUDY 114 S MDSTUDY=+DATA,MDRESUL="" 115 ; Create New TIU Document 116 S MDRESUL=$$NEWTIUN(MDSTUDY) 117 ; File TIU Error messages 118 ;I +MDRESUL<0 D FILEMSG(MDSTUDY,"TIU",2,MDRESUL) Q MDRESUL 119 I +MDRESUL<0 D Q 120 .D FILEMSG(MDSTUDY,"TIU",2,MDRESUL) 121 .S @RESULTS@(0)=MDRESUL 122 ; Submit and export the images 123 S MDRESUL=$$SUBMIT^MDRPCOT1(MDSTUDY) 124 ; File message 125 D FILEMSG(MDSTUDY,"IMAGING",$S(+MDRESUL>0:+MDRESUL,1:2),MDRESUL) 126 S @RESULTS@(0)=MDRESUL 127 Q 128 ; 129 VIEWTIU ; [Procedure] VIew the associated tiu document 130 I '$P(^MDD(702,+DATA,0),U,6) D Q 131 .S @RESULTS@(0)="NO TIU NOTE FOR THIS STUDY" 132 D TGET^TIUSRVR1(.RESULTS,+$P(^MDD(702,+DATA,0),U,6)) 133 Q 134 ; 135 GETDATA(STUDY) ; [Function] Return the Necessary data for creating a TIU note. 136 ; Return: Patient DFN_"^"_TIU title_"^"_Hospital Location_"^"_TIU Note 137 ; IEN_"^"_Consult #_"^"_CP Definition IEN_"^"_Visit String_"^" 138 ; New Visit Flag 139 ; or 140 ; -1^Error Message 141 N DFN,MDCON,MDFN,MDIEN,MDIENS,MDLOC,MDNEWV,MDNOTE,MDNVST,MDPROC,MDVSTR,MDTITL,MDX,MDTST 142 S MDIEN=+STUDY,MDIENS=MDIEN_",",MDNVST=0 143 I $$GET1^DIQ(702,MDIENS,.01)="" Q "-1^No such study entry." 144 ; Get DFN 145 S DFN=$$GET1^DIQ(702,MDIEN,.01,"I") 146 I 'DFN Q "-1^No DFN." 147 ; Get CP Def 148 S MDPROC=$$GET1^DIQ(702,MDIEN,.04,"I") 149 I 'MDPROC Q "-1^No CP Def." 150 ; Get Consult 151 S MDCON=$$GET1^DIQ(702,MDIEN,.05,"I") 152 I 'MDCON Q "-1^No Consult #." 153 ; Get TIU Note Title 154 S MDTITL=$$GET1^DIQ(702.01,+MDPROC_",",.04,"I") 155 I 'MDTITL Q "-1^No TIU Note Title." 156 S MDVSTR=$$GET1^DIQ(702,MDIEN,.07) 157 I MDVSTR="" Q "-1^No Visit String." 158 I $L(MDVSTR,";")=1 S MDNVST=1,MDVSTR=";"_MDVSTR ; If new visit is selected 159 ; MDLOC is Hospital Location 160 I MDVSTR'="" D 161 .S MDVSTR=$$GETVSTR^MDRPCOT1(DFN,MDVSTR,MDPROC,$$GET1^DIQ(702,MDIEN,.02,"I")) 162 .S MDLOC=$P(MDVSTR,";",1) 163 ; Does TIU doc already exist? 164 I $$GET1^DIQ(702,MDIEN,.06,"I") Q DFN_"^"_MDTITL_"^"_MDLOC_"^"_+$$GET1^DIQ(702,MDIEN,.06,"I")_"^"_MDCON_"^"_MDPROC_"^"_MDVSTR_"^"_MDNVST 165 ; Does TIU doc exist for previous transaction of this consult? 166 I MDCON S MDNOTE=$$PREV(MDCON,MDIEN) 167 Q DFN_"^"_MDTITL_"^"_MDLOC_"^"_+MDNOTE_"^"_MDCON_"^"_MDPROC_"^"_MDVSTR_"^"_MDNVST 168 ; 169 NEWTIUN(STUDY) ; [Function] Create a new TIU for transaction 170 ; Input: STUDY - IENS of CP study entry 171 ; Return: TIU Document IEN 172 N CTR,DFN,MDCON,MDFDA,MDGST,MDL,MDLOC,MDNOTE,MDPDT,MDPROC,MDRESU,MDTITL,MDTSTR,MDVST,MDVSTR,MDWP S CTR=0,MDGST=+STUDY,MDRESU="" 173 ; Get data for TIU Note Creation 174 S (MDTSTR,MDRESU)=$$GETDATA(MDGST) 175 ; File Error message 176 I +MDRESU<0 D FILEMSG(MDGST,"CP",2,MDRESU) Q MDRESU 177 I $G(MDTSTR)="" Q "-1^No Data to Create TIU Document" 178 F MDL="DFN","MDTITL","MDLOC","MDNOTE","MDCON","MDPROC","MDVSTR","MDNVST" D 179 .S CTR=CTR+1,@MDL=$P(MDTSTR,"^",CTR) 180 S MDVST="" 181 ; If previous TIU document exists, quit 182 I MDNOTE Q MDNOTE 183 I 'MDLOC Q "-1^No Hospital Location." 184 ; Create new visit, if no vstring 185 S MDPDT=$$PDT^MDRPCOT1(MDGST) 186 S:'MDPDT MDPDT=$P(MDVSTR,";",2) ; If No D/T Performed grab visit D/T 187 ; Build variables for TIU Call 188 S MDWP(.05)=1 ; Undicated Status 189 S MDWP(1405)=+MDCON_";GMR(123," ; Package Reference 190 I MDPDT S MDWP(70202)=MDPDT ; Date/Time Performed 191 ; File PCE Error message 192 I MDNVST S MDRESU=$$EN1^MDPCE(MDGST,MDPDT,MDPROC,$P(MDVSTR,";",3),"P") I +MDRESU S MDVST=+MDRESU,MDVSTR=$P(MDRESU,"^",2) 193 I MDNVST&(+MDRESU<0) D FILEMSG(MDGST,"PCE",2,$P(MDRESU,"^",2)) Q MDRESU 194 ; Create the TIU note stub 195 S MDNOTE="" D MAKE^TIUSRVP(.MDNOTE,DFN,MDTITL,$P(MDVSTR,";",2),MDLOC,$S(MDVST:MDVST,1:""),.MDWP,MDVSTR,1,1) 196 I '(+MDNOTE) S $P(MDNOTE,"^")=-1 Q MDNOTE 197 ; Finalize the transaction 198 S MDFDA(702,STUDY_",",.06)=+MDNOTE 199 S MDFDA(702,STUDY_",",.08)="" 200 D FILE^DIE("","MDFDA") 201 Q 1 202 ; 203 PREV(MDC,MDS) ; [Function] Return the Previous TIU document. 204 N MDNEWV,MDDOC,MDTRAN,MDTIUER,MDTST 205 S (MDDOC,MDNEWV,MDTRAN,MDTIUER,MDTST)="" K ^TMP("MDTIUST",$J) 206 F S MDTRAN=$O(^MDD(702,"ACON",MDC,MDTRAN)) Q:'MDTRAN D Q:'MDTRAN 207 .I $P(^MDD(702,MDTRAN,0),U,6) D 208 ..D EXTRACT^TIULQ($P(^MDD(702,MDTRAN,0),U,6),"^TMP(""MDTIUST"",$J)",MDTIUER,".01;.05;1406") Q:+MDTIUER 209 ..S MDTST=$G(^TMP("MDTIUST",$J,$P(^MDD(702,MDTRAN,0),U,6),.05,"E")) 210 ..I MDTST'="UNDICTATED"&(MDTST'="UNSIGNED") K ^TMP("MDTIUST",$J) Q 211 ..I MDTST="UNSIGNED"&'($G(^TMP("MDTIUST",$J,$P(^MDD(702,MDTRAN,0),U,6),1406,"I"))) K ^TMP("MDTIUST",$J) Q 212 ..S MDDOC=$P(^MDD(702,MDTRAN,0),U,6),MDNEWV=$P(^MDD(702,MDTRAN,0),U,7) 213 ..Q:'MDS 214 ..S MDFDA(702,MDS_",",.06)=MDDOC 215 ..S MDFDA(702,MDS_",",.07)=MDNEWV 216 ..D FILE^DIE("","MDFDA") 217 ..S MDTRAN="" 218 Q MDDOC 219 ;
Note:
See TracChangeset
for help on using the changeset viewer.
