Changeset 636 for FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD

Timestamp:

Dec 4, 2009, 8:26:01 PM (15 years ago)

Author:

George Lilly

Message:

WorldVistAEHR overlayed on FOIAVistA

Location:

FOIAVistA/tag/r

Files:

• . (copied) (copied from FOIAVistA/trunk/r )
• CLINICAL_PROCEDURES-MD/MDAPI.m (modified) (7 diffs)
• CLINICAL_PROCEDURES-MD/MDHL7A.m (modified) (9 diffs)
• CLINICAL_PROCEDURES-MD/MDHL7MCA.m (modified) (2 diffs)
• CLINICAL_PROCEDURES-MD/MDHL7U3.m (modified) (2 diffs)
• CLINICAL_PROCEDURES-MD/MDHL7X.m (modified) (2 diffs)
• CLINICAL_PROCEDURES-MD/MDRPCOG.m (modified) (2 diffs)
• CLINICAL_PROCEDURES-MD/MDRPCOP.m (modified) (8 diffs)
• CLINICAL_PROCEDURES-MD/MDRPCOT.m (modified) (10 diffs)

FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDAPI.m

@@ -1 +1 @@
 MDAPI ; HOIFO/DP/NCA - CP API Calls ; [05-05-2003 10:28]
- ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
+ ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
  ; Description:
  ; These API's are for use by external packages communicating with CP.
  ;
  ; Integration Agreements:
- ; IA# 3378 [Subscription] Documents the APIs that external packages use to communicate with CP.
+ ; IA# 3378 [Restricted] Documents the APIs that external packages use to communicate with CP.
  ; IA# 3468 [Subscription] Use GMRCCP APIs.
  ;
@@ -138 +138 @@
  ;  1. MDNOTE [Literal/Required] TIU IEN
  ;
- N MDGBL,MDRES,MDFDA,MDTRAN,RESULTS
+ N MDRES,MDFDA,RESULTS
  S MDRES="" F  S MDRES=$O(^MDD(702,"ATIU",MDNOTE,MDRES)) Q:'MDRES  D
  .Q:$G(^MDD(702,+MDRES,0))=""
- .;S MDFDA(702,MDRES_",",.05)=""
+ .S MDFDA(702,MDRES_",",.05)=""
  .S MDFDA(702,MDRES_",",.06)=""
  .D FILE^DIE("","MDFDA")
- .S MDTRAN=$O(^MDD(702.001,"ASTUDY",MDRES,MDNOTE,0)) I +MDTRAN N DA,DIK S DA=+MDTRAN,DIK="^MDD(702.001," D ^DIK
  .D STATUS^MDRPCOT(MDRES_",",2,"TIU note deleted.")
  .S DATA("TRANSACTION")=MDRES,DATA("PKG")="TIU"
  .S DATA("MESSAGE")="TIU note deleted." D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA)
- 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
  Q 1
  ;
@@ -161 +159 @@
  ;  7. MDNTIU [Literal/Required] The new reassigned TIU document IEN.
  ;
- N MDD,MDGBL,MDTRAN,MDCHK,MDLP,MDMULN,MDN,MDPPR,MDREAS,MDTRANI,MDX
+ N MDD,MDTRAN,MDCHK,MDLP,MDPPR,MDREAS,MDTRANI,MDX
  I '$G(MDFN) Q "0^No DFN for the TIU note re-assignment."
  I '$G(MDOLDC) Q "0^No Old Consult # for the note re-assignment."
@@ -169 +167 @@
  I '$G(MDNTIU) Q "0^No New Reassigned TIU IEN."
  S (MDD,MDCHK,MDREAS,MDTRAN)="",MDPPR=0 K ^TMP("MDTMP",$J)
- S MDTRAN=$O(^MDD(702,"ATIU",MDANOTE,0)) I +MDTRAN S MDCHK=$G(^MDD(702,MDTRAN,0)),MDTRANI=MDTRAN_"," D
+ F  S MDTRAN=$O(^MDD(702,"ACON",MDOLDC,MDTRAN)) Q:'MDTRAN  D
+ .S MDCHK=$G(^MDD(702,MDTRAN,0)),MDTRANI=MDTRAN_","
  .I $P(MDCHK,U,5)=MDOLDC&($P(MDCHK,U,6)=MDANOTE) D
- ..S MDFDA(702,+MDTRAN_",",.06)=""
- ..D FILE^DIE("","MDFDA") K MDFDA
- S MDGBL=$NA(^MDD(702.001,"PK",MDANOTE))
- 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
- S MDMULN=+$O(^MDD(702.001,"ASTUDY",+MDTRAN,0))
- I '+MDMULN I +MDTRAN N DA,DIK S DA=+MDTRAN,DIK="^MDD(702," D ^DIK
- D NOW^%DTC S MDD=% S MDTRANI=$O(^MDD(702,"ACON",MDNEWC,0))
- S MDREAS=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";")
- I +MDTRANI&(MDNDFN=+$G(^MDD(702,+MDTRANI,0))) D
- .S MDPPR=$P($G(^MDD(702,+MDTRANI,0)),"^",4) Q:'MDPPR
- .S MDNEWV=$$GETVSTR^MDRPCOT1(MDNDFN,MDREAS,MDPPR,MDD)
- .S MDFDA(702,+MDTRANI_",",.06)=MDNTIU
- .S MDFDA(702,"+1,",.07)=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";")
- .D FILE^DIE("","MDFDA") K MDFDA
+ ..S:'MDPPR MDPPR=$P(MDCHK,U,4)
+ ..N DA,DIK S DA=+MDTRAN,DIK="^MDD(702," D ^DIK
  I 'MDPPR D
  .D CPLIST^GMRCCP(MDNDFN,,$NA(^TMP("MDTMP",$J)))
@@ -190 +177 @@
  .F  S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX  S:$P(^(MDX),U,5)=MDNEWC MDPPR=$P(^(MDX),U,6)
  K ^TMP("MDTMP",$J)
- I +MDPPR Q 1
+ I 'MDPPR Q 1
+ D NOW^%DTC S MDD=%
+ S MDREAS=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";")
  S MDNEWV=$$GETVSTR^MDRPCOT1(MDNDFN,MDREAS,MDPPR,MDD)
  S MDFDA(702,"+1,",.01)=MDNDFN
@@ -200 +189 @@
  S MDFDA(702,"+1,",.07)=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";")
  S MDFDA(702,"+1,",.09)=0
- D UPDATE^DIE("","MDFDA")
+ D UPDATE^DIE("","MDFDA","MDTRANI") Q:'$G(MDTRANI(1)) 1
  Q 1
  ;
@@ -210 +199 @@
  Q STR
  ;
-GETCP(RESULTS,MDCSLT) ; API to return CP Study data
- ; Input Parameters:
- ;   1. RESULTS [Literal/Required] Return Array
- ;   2. MDCSLT [Literal/Required] Consult number
- ;
- ; Output:
- ;   RESULTS(0)=-1^Error Message or 1 for success
- ;          (N,1)=CP Study Number
- ;          (N,2)=Patient DFN
- ;          (N,3)=Created Date/Time
- ;          (N,4)=Created By
- ;          (N,5)=CP Definition (External Name)
- ;          (N,6)=Consult Number
- ;          (N,7)=TIU Note IEN
- ;          (N,8)=VSTR
- ;          (N,9)=Transaction Status
- ;
- ; Where N = 1..n entries
- ;
- N MDCT,MDX,MDY
- I '$G(MDCSLT) S @RESULTS@(0)="-1^No Consult Number passed" Q
- S MDX=$O(^MDD(702,"ACON",MDCSLT,0)) I 'MDX S @RESULTS@(0)="-1^No CP Study Entry." Q
- S @RESULTS@(0)=1
- S MDCT=0,MDX="" F  S MDX=$O(^MDD(702,"ACON",MDCSLT,MDX)) Q:MDX<1  D
- .S MDCT=MDCT+1,@RESULTS@(MDCT,1)=MDX
- .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")
- .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")
- Q

FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDHL7A.m

@@ -1 @@
-MDHL7A ; HOIFO/WAA - Routine to Decode HL7 for CP ;9/17/07  08:17
- ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
+MDHL7A ; HOIFO/WAA - Routine to Decode HL7 for CP ; [05-07-2001 10:38]
+ ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
  ; Reference DBIA #10035 [Supported] for DPT calls.
  ; Reference DBIA #10106 [Supported] for HLFNC calls.
  ; Reference DBIA #10062 [Supported] for VADPT6 calls.
- ; Reference DBIA #2701 [Supported] for MPIF001 calls
- ; Reference DBIA #10096 [Supported] for ^%ZOSF calls
+ ; Reference DBIA #2701 [Supported] for MPIF001 Calls
 EN ; [Procedure] Entry Point for Message Array in MSG
  N %,BID,CODE,CPT,DA,DATE,DFN,DIK,DLCO,DTO,DZ,ERRTX,EXAM,EXE,MDFLAG,FIL
@@ -13 +12 @@
  N ECODE,MDIEN,MDOBX,NUMZ,PNAM,ZCODE,MDDEV,MDD702,DEVNAME,DEVIEN,MDQFLG
  N MDIORD
- K ^TMP($J,"MDHL7A"),^TMP($J,"MDHL7"),^TMP($J,"MDHL7A1")
+ K ^TMP($J,"MDHL7A"),^TMP($J,"MDHL7")
  S MDFLAG=0,MDERROR=0,MDQFLG=0
- Q:$G(HLMTIENS)=""
- S ^TMP($J,"MDHL7A1")=""
- S HLREST="^TMP($J,""MDHL7A1"")"
- S X=$$MSGIEN^MDHL7U3(HLMTIENS,HLREST) ; This code is to convert the HL7 Message **6**
- I $P(X,U)=0 D  Q
- . S DEVIEN=0,ECODE=0
- . S ERRTX=$P(X,U,2)
- . D ^MDHL7X
- . Q
- I $P(X,U)=1 D XVERT^MDHL7U3("MDHL7A1","MDHL7A")
- K HLNODE,^TMP($J,"MDHL7A1")
+ 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),"")
+ K HLNODE
  ;
 EN2 ; [Procedure] No Description
- S (DEVIEN,DEVNAME)="",I=0
+ S (DEVIEN,DEVNAME)=""
  F I=1:1 S X=$G(^TMP($J,"MDHL7A",I)) Q:X=""  Q:$E(X,1,3)="OBX"  D
  . S:$E(X,1,3)="MSH" DEVNAME=$P(X,"|",4)
- . I DEVNAME="",HLREC("SFN")'="" S DEVNAME=HLREC("SFN")
  . I $E(X,1,3)="MSH",DEVNAME'="Instrument Manager" S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0))
  . I $E(X,1,3)="OBR" D
@@ -58 +47 @@
  I (ZCODE="M")!(ZCODE="B") D  Q:MDERROR  Q:ZCODE="M"  ;
  . S MDFLAG=1,MDERROR=0 ; Tell Medicine that CP is talking to HL7
+ . ;S MSG(1)=^TMP($J,"MDHL7A",1)
+ . ;S MSG(2)=^TMP($J,"MDHL7A",2)
  . D ^MDHL7MCA ; Run the Medicine routines
  . Q:MDERROR  ; Medicine found an error and sent an error back
+ . ;;I ZCODE="M" D GENACK^MDHL7X
  . Q
  S NUMZ=$O(^TMP($J,"MDHL7A",""),-1)
@@ -104 +96 @@
  S MDIORD=$P(X,"|",4)
  S MDD702=$S(+MDIORD<1:"",1:$$GETSTDY^MDRPCOT1(MDIORD))
- ;I MDD702'="" S MDD702=$$CHK^MDNCHK(MDD702) ; PATCH 11
  S ORIFN=$P(X,"|",3),(EXAM,%)=$P(X,"|",5) I EXAM'="" S EXAM=$P(%,"^",2) I EXAM="" S EXAM=$P(%,"^",1)
  S CPT=$P(X,"|",5) I $P(CPT,"^",3)["CPT" S CPT=$P(CPT,"^",1)
@@ -110 +101 @@
  ;  vvv== Added to address the issues of mismatch
  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
- 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
  I DTO="" S ERRTX="Missing required Date/Time of Procedure in OBR" D ^MDHL7X Q
  ;;S UNIQ=$TR($H,",","-")
@@ -119 +109 @@
  S MDRTN=$P($G(^MDS(702.09,INST,.1)),"^",1) S:MDRTN'["^" MDRTN="^"_MDRTN
  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
- D CPTICD^MDHL7U3(X,MDIEN) ; Update CPT and ICD9
- D PHY^MDHL7U3(X,MDIEN) ; Get Doc who did the procedure.
  Q
  ;
@@ -126 +114 @@
  S X=$G(^TMP($J,"MDHL7A",NUM)) I $E(X,1,3)'="PID" S ERRTX="PID not second record" D ^MDHL7X Q
  S SEG("PID")=X
- S MDDOB=$P(X,"|",8) I MDDOB'="" S MDDOB=($E(MDDOB,1,4)-1700)_$E(MDDOB,5,8)
  I $L($P(X,"|",4))'<16 D  I +DFN=-1 Q
  . N ICN
@@ -154 +141 @@
  ;
 OBX ; [Observation]
+ ;Q:$P(^TMP($J,"MDHL7A",NUM),"|")'="OBX"
  D @MDRTN
  Q
 NEWID(DFN,DATE,INST,MDD702,HLMTIEN) ; Generate a new entry and ID of 703.1
- N NEWID,MDFDA,MDIEN,MDNO
+ N NEWID,MDFDA,MDIEN
  S NEWID=$TR($H,",","-")  ; Create inital ID
  L +(^MDD(703.1,"B")):60 E  Q "-1"
- ;^^--- Unable to get a lock in the file
+ ;^^--- Unable to get an lock in the file
  F  Q:'$D(^MDD(703.1,"B",NEWID))  H 1 S NEWID=$TR($H,",","-")
- ;^^--- Search to create a new ID if current ID is in use
+ ;^^--- Search to create an new ID in current ID is in use
  S MDFDA(703.1,"+1,",.01)=NEWID
  S MDFDA(703.1,"+1,",.02)=DFN
@@ -171 +159 @@
  D UPDATE^DIE("","MDFDA","MDIEN")
  L -(^MDD(703.1,"B"))
- I $G(MDIEN(1))>0 D  Q MDIEN(1)_U_NEWID
- . S ^MDD(703.1,MDIEN(1),.1,0)="^703.11S^0^0"
- . S MDNO=$$NTIU^MDRPCW1(+MDD702)
- . Q
+ I $G(MDIEN(1))>0 S ^MDD(703.1,MDIEN(1),.1,0)="^703.11S^0^0" Q MDIEN(1)_U_NEWID
  ; ^^--- Create Subfile and quit
  Q "-1"  ; Unable to create file

FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDHL7MCA.m

@@ -1 @@
-MDHL7MCA ; HOIFO/REL-Routine to Decode HL7 for MEDICINE ; [05-07-2001 10:38]
- ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
+MDHL7MCA ; HIRMFO/REL-Routine to Decode HL7 for MEDICINE ; [05-07-2001 10:38]
+ ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
  ; Reference DBIA #10035 for DPT calls.
  ; Reference DBIA #10062 for VADPT calls.
  ; Reference DBIA #10106 for HL7 calls.
- ; Reference DBIA #10096 for ^%ZOSF calls.
 EN ; Entry Point for Message Array in MSG
  N MSG
@@ -38 +37 @@
  ;I $E(MSG(NUM),1,3)="ORC" S NUM=NUM+1
 OBR ; Check OBR
+ W MSG(NUM)
  S X=$G(MSG(NUM)) I $E(X,1,3)'="OBR" S ERRTX="OBR not found when expected" D ^MDHL7MCX G KIL
  S SEG("OBR")=X

FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDHL7U3.m

@@ -1 +1 @@
 MDHL7U3 ; HOIFO/WAA -Utilities for CP to process HL7 messages  ; 7/26/00
- ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
- ; Reference DBIA #2729 [Supported]  for XMXPAI
+ ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
  ; Reference DBIA #4262 [Supported] for HL7 call.
- ; Reference DBIA #3273 [Subscription] for HL7 call.
- ; Reference DBIA #10138 [Supported] for HL7 call.
- ; Reference DBIA #3990 [Supported] for ICDCODE call
- ; Reference DBIA #1131 [Supported] for XMB("NETNAME") reference
- ; Reference DBIA #1995 [Supported] for ICPTCOD to handle CPT Codes call
- ; Reference DBIA #10082 [Supported] for ^ICD9 reference
- ; Reference DBIA #10111 [Supported] for FILE 3.8 call
- ; Reference DBIA #10103 [Supported] for XLFDT call
- ;
-HL7CHK(MDD702) ; Check to see of there is an entry in 703.1 for a patient.
- N X
- S X="1^"
- D
- . N Y
- . I $G(^MDD(702,MDD702,0))="" S X="-1^No Entry in 702." Q
- . I $D(^MDD(703.1,"ASTUDYID",MDD702))=0 Q
- . S Y=0
- . S Y=$O(^MDD(703.1,"ASTUDYID",MDD702,Y)) I Y>0 S X="-1^This Study has Data on file."
- . Q
- Q X
-XVERT(MDA,MDB) ; Strip out blank Lines
- Q:MDA=""
- Q:MDB=""
- Q:$G(^TMP($J,MDA,1))
- N I,CNT,CNT2,NODE,FLG
- S (CNT,I,FLG)=0
- F  S I=$O(^TMP($J,MDA,I)) Q:I<1  D
- . S NODE=$TR(^TMP($J,MDA,I),$C(10),"")
- . I NODE="" S FLG=0 Q
- . I FLG  D  Q
- . . S CNT2=CNT2+1
- . . S ^TMP($J,MDB,CNT,CNT2)=NODE
- . . Q
- . I 'FLG D  Q
- . . S CNT=CNT+1
- . . S ^TMP($J,MDB,CNT)=NODE
- . . S FLG=1,CNT2=0
- . . Q
- . Q
- Q
  ;
 PURGE(MDD7031) ;
@@ -52 +11 @@
  S $P(^MDD(703.1,MDD7031,0),U,6)=""
  Q
- ;
-PHY(X,MDIEN) ; Add the doc who did the exam to the report
- Q
- ; This will be implemented with the Doctor Lookup when it comes out.
- N LINE1,LINE
- S LINE1=$P(X,"|",17)
- S LINE=$P(LINE1,"^",2) ; Last
- S LINE=LINE_$S($P(LINE1,"^",3)'="":", "_$P(LINE1,"^",3),1:"") ; First
- S LINE=LINE_$S($P(LINE1,"^",4)'="":" "_$P(LINE1,"^",4),1:"") ; MI
- D ADD(MDIEN,"9",LINE)
- Q
- ;
-CPTICD(X,MDIEN) ; Break out CPT and ICD9 codes
- N ICD,CPT
- Q:MDIEN<1
- S CPT=$P(X,"|",45) I CPT'="" D FILECD(MDIEN,CPT,"7")
- S ICD=$P(X,"|",14) I ICD'="" D FILECD(MDIEN,ICD,"8")
- Q
-FILECD(MDIEN,CODE,TYPE) ; fILE THE DATA
- N LINE,Y,I,CNT,RESULT
- S CNT=$L(CODE,"~")
- S LINE=""
- F I=1:1:CNT S Y=$P(CODE,"~",I),RESULT=$P(Y,"^",1),LINE(.2,I,0)=RESULT
- S LINE(.2,0)="^^"_CNT_"^"_CNT_"^"_$P(%,".")
- Q:CNT<1  ; file the results if there is any
- D ADD(MDIEN,TYPE,.LINE,CNT)
- Q
- ;
-ADD(MDIEN,TYPE,LINE,CNT) ;
- ; Create an entry in the .1 node
- N NODE,X
- S NODE=$G(^MDD(703.1,MDIEN,.1,0)) Q:NODE=""
- S NODE=$P(NODE,"^",3)
- S NODE=NODE+1
- S $P(^MDD(703.1,MDIEN,.1,0),"^",3,4)=NODE_"^"_NODE
- S $P(^MDD(703.1,MDIEN,.1,NODE,0),"^")=TYPE
- D NOW^%DTC
- M ^MDD(703.1,MDIEN,.1,NODE)=LINE
- Q
- ;
-MSGIEN(MDHLIENS,MDHLREST) ; Return the message as definded in MDHLIENS  to the array in MDHLREST
- ; Only TCP type messages
- ; input: MDHLIENS= the intern entry number of the message in ^HLMA
- ; MDHLREST = the return array that will contain the whole HL7 message
- ; output: return "1^Message complete" if message was successful, "0^reason" if failed.
- ;
- N MDHLIEN,MDHLI,MDHLCNT,MDHLZ,RET
- S (MDHLCNT,MDHLI,RET)=0
- I $G(MDHLIENS)="" S RET=RET_"^No IEN defined" Q RET  ; Exit because no IEN for ^HLMA was provided
- I $G(MDHLREST)="" S RET=RET_"^No Return ARRAY provided" Q RET  ; Exit because no return array was provided
- I $G(^HLMA(MDHLIENS,0))="" S RET=RET_"^HLMA entry does not exist" Q RET  ; Exit because invalid OR non-EXISTING HLMA ENTRY
- S MDHLIEN=$P(^HLMA(MDHLIENS,0),U)
- I MDHLIEN="" S RET=RET_"^No pointer value to file 772" Q RET  ; No Pointer to 772
- I $G(^HL(772,MDHLIEN,0))="" S RET=RET_"^772 Entry does not exist" Q RET  ; No 772 entry exist
- ;get header
- S MDHLZ=$G(^HLMA(MDHLIENS,"MSH",1,0))
- I MDHLZ="" S RET=RET_"^No MSH segment found" Q RET  ; No MSH was found
- S MDHLCNT=MDHLCNT+1,@MDHLREST@(MDHLCNT)=MDHLZ
- S MDHLCNT=MDHLCNT+1,@MDHLREST@(MDHLCNT)=""
- ;get body
- S MDHLI=0
- F  S MDHLI=$O(^HL(772,MDHLIEN,"IN",MDHLI)) Q:'MDHLI  D
- . S MDHLCNT=MDHLCNT+1
- . S @MDHLREST@(MDHLCNT)=$G(^HL(772,MDHLIEN,"IN",MDHLI,0))
- . Q
- I MDHLCNT'>2 S RET=RET_"^No message body found" Q RET  ; There was no body
- S RET="1^Message complete"
- Q RET
- ;
-CICNV(MDIEN,RETURN) ; This subroutine will read the data in 703.1 and return the results 
- ;in the indicated global
- N NODE,FLG
- S FLG=1
- Q:MDIEN=""  ; The ien was null
- Q:RETURN=""  ; the array was null
- S ARRAY(0)="0^0"
- I $G(^MDD(703.1,MDIEN,.1,0))="" S FLG=0 Q  ; There is not data.
- ; Start the processing of ICD/POV codes Value is 8
- S NODE=0
- I FLG I $G(^MDD(703.1,MDIEN,.1,0))'="" D
- . F  S NODE=$O(^MDD(703.1,MDIEN,.1,NODE)) Q:NODE<1  D
- . . S TYPE=$P($G(^MDD(703.1,MDIEN,.1,NODE,0),0),"^",1)
- . . I TYPE=8 D PROCESS(MDIEN,NODE,TYPE,.ARRAY)
- . . I TYPE=7 D PROCESS(MDIEN,NODE,TYPE,.ARRAY)
- . . Q
- . Q
- M @RETURN=ARRAY
- Q
-PROCESS(MDIEN,NODE,TYPE,ARRAY) ; This will process the data for each
- N CNT,X,CONT,CODE,AR,TP,LOC
- S CNT=0,CONT=0
- F  S CNT=$O(^MDD(703.1,MDIEN,.1,NODE,.2,CNT)) Q:CNT<1  D
- . S CODE=$G(^MDD(703.1,MDIEN,.1,NODE,.2,CNT,0),"") ; Grabbing the ICD9 AND CPT codes
- . I CODE="" Q
- . I TYPE=8 S AR=1,TP="POV",X=$$ICDDX^ICDCODE(CODE) Q:X=""  ; Reference DBIA #3990 [Supported] for ICDCODE call
- . 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
- . S CONT=CONT+1
- . S ARRAY(AR)=CONT_"^"_CONT
- . I AR=1 D
- . . N DESC,IN,LN
- . . S IN=$P(X,"^",1) Q:IN<1
- . . S LN=$G(^ICD9(IN,0),0) Q:LN=""
- . . S DESC=$P(LN,"^",3) Q:DESC=""
- . . S I=CONT
- . . S $P(ARRAY(AR,I),"^",1)=TP
- . . S $P(ARRAY(AR,I),"^",2)=$P(X,"^",1)
- . . S $P(ARRAY(AR,I),"^",3)=$P(X,"^",2)
- . . S $P(ARRAY(AR,I),"^",5)=DESC
- . . S $P(ARRAY(AR,I),"^",6)=$S(I=1:1,1:0)
- . . Q
- . I AR=2 D
- . . N DESC,IN,LN
- . . S IN=$P(X,"^",1) Q:IN<1
- . . ; S LN=$G(^ICPT(IN,0),0) Q:LN=""
- . . S DESC=$P(X,"^",3) Q:DESC=""  ; DBIA1995 $$CPT^ICPTCOD(CODE) returns X and the second piece of X is the DESC
- . . S I=CNT
- . . S $P(ARRAY(AR,I),"^",1)=TP
- . . S $P(ARRAY(AR,I),"^",2)=$P(X,"^",1)
- . . S $P(ARRAY(AR,I),"^",3)=$P(X,"^",2)
- . . S $P(ARRAY(AR,I),"^",5)=DESC
- . . S $P(ARRAY(AR,I),"^",7)=$S(I=1:1,1:0)
- . . Q
- . Q
- I $D(ARRAY(1))!$D(ARRAY(2)) S ARRAY(0)="1^1"
- Q
- ;
-NOTICE(SUBJECT,TXT,DEVIEN,DUZ) ; This will fire off a mail message to the Indicated mail group saying that a study was deleted
- ;
- N INST,MG,XMTO,XMDUZ,XMSUBJ,XMBODY,N,X
- S MG=0
- S INST=DEVIEN
- I INST>1 S MG=$P($G(^MDS(702.09,INST,0)),"^",2)
- I 'MG!('$$MG^MDHL7U2(MG)) S MG=$$FIND1^DIC(3.8,"","BX","MD DEVICE ERRORS") Q:'MG
- S MG=$$GET1^DIQ(3.8,+MG_",",.01)
- S XMTO="G."_MG_"@"_^XMB("NETNAME"),XMINSTR("FROM")=.5
- S XMBODY="TXT"
- S XMSUBJ=SUBJECT
- D SENDMSG^XMXAPI(DUZ,XMSUBJ,XMBODY,XMTO,.XMINSTR)
- Q
- ;
-ALERT(MDSIEN) ; This is to send an e-mail to the main device mail group that a study has been deleted
- D NOW^%DTC
- S SUBJECT="Study "_MDSIEN_" for Patient "_$$GET1^DIQ(702,MDSIEN,.01,"E")_" has been DELETED!"
- S BODY(1)="The following study has been deleted."
- S BODY(2)="         By the USER:       "_$$GET1^DIQ(200,DUZ,.01,"E")
- S BODY(3)="             On Date:       "_$$FMTE^XLFDT(%,1)
- S BODY(4)="           "
- S BODY(5)="                   CP Study Information"
- S BODY(6)="------------------------------------------------------------------------------ "
- S BODY(7)="CP Study ID:       "_MDSIEN
- S BODY(8)="CP Study Def:      "_$$GET1^DIQ(702,MDSIEN,.04,"E")
- S BODY(9)="Created on:        "_$$FMTE^XLFDT($$GET1^DIQ(702,MDSIEN,.02,"I"),1)
- S BODY(10)="Created by:        "_$$GET1^DIQ(702,MDSIEN,.03,"E")
- S BODY(11)="On Instrument:     "_$$GET1^DIQ(702,MDSIEN,.11,"E")
- S BODY(12)="For Patient:       "_$$GET1^DIQ(702,MDSIEN,.01,"E")
- S BODY(13)="        SSN:       "_$E($$GET1^DIQ(702,MDSIEN,.011,"E"),6,9)
- S BODY(14)="        DOB:       "_$$FMTE^XLFDT($$GET1^DIQ(702,MDSIEN,.012,"I"),1)
- S DEVIEN=$$GET1^DIQ(702,MDSIEN,.11,"I")
- Q

FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDHL7X.m

@@ -1 +1 @@
 MDHL7X ; HOIFO/WAA -Generate HL7 Error Message ; 06/08/00
- ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
+ ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
  ; Reference IA #1131 for ^XMB("NETNAME") access.
  ; Reference IA #2165 for HLMA1 calls.
@@ -12 +12 @@
  S MG=$$GET1^DIQ(3.8,+MG_",",.01)
  S XMTO="G."_MG_"@"_^XMB("NETNAME"),XMINSTR("FROM")=.5
- I '$D(X) S X=$G(ECODE(0))
+ I '$D(X) S X=ECODE(0)
  S TXT(1)=ERRTX,TXT(2)=X,TXT(3)=" "
  S N=3
- I '$G(ECODE,1) D  ; This is to process Device errors
+ I 'ECODE D  ; This is to process Device errors
  . N X
  . S X=0

FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDRPCOG.m

@@ -1 +1 @@
 MDRPCOG ; HOIFO/DP - CP Gateway ; [01-09-2003 15:20]
- ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
+ ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
  ; Description:
  ; This is the main routine that manages the CLINICAL PROCEDURES Gateway functions.  
@@ -116 +116 @@
  Q
  ;
-RUNNING ; [Procedure] Returns 0/1 and message on running status
- ; Note: If lock CAN be obtained, then gateway is NOT running
- L +^MDD("CPGATEWAY"):1 E  S @RESULTS@(0)="1^RUNNING" Q
- L -(^MDD("CPGATEWAY")) S @RESULTS@(0)="0^NOT RUNNING"
- Q
- ;
 SETFILE ; [Procedure] Set filename of new attachment
  S MDFDA(703.11,$P(DATA,U,1),.02)=$P(DATA,U,2)

FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDRPCOP.m

@@ -1 @@
-MDRPCOP ; HOIFO/DP - Object RPCs (TMDPatient) ;3/12/08  09:16
- ;;1.0;CLINICAL PROCEDURES;**4,6**;Apr 01, 2004;Build 102
+MDRPCOP ; HOIFO/DP - Object RPCs (TMDPatient) ; [01-09-2003 15:21]
+ ;;1.0;CLINICAL PROCEDURES;**4**;Apr 01, 2004;Build 3
  ; Integration Agreements:
- ; IA# 2263 [Supported] XPAR calls
  ; IA# 3027 [Supported] Calls to DGSEC4
  ; IA# 2981 [Subscription] Calls to GUI~GMRCP5
@@ -9 +8 @@
  ; IA# 10061 [Supported] VADPT calls.
  ; IA# 3468 [Subscription] Use GMRCCP APIs.
+ ; IA# 3266 [Subscription] Call to DPTLK1
  ; IA# 10103 [Supported] Call to XLFDT
  ; IA# 10039 [Supported] Ward Location File (#42) Access.
  ; IA# 10035 [Supported] DPT references
+ ; IA# 3267 [Subscription] Call to DPTLK1
+ ; IA# 3593 [Supported] Access to routine DPTLK6 utilities for lookup
  ; IA# 3613 [Private] GETVST^MDRPCOP API call
  ; IA# 10099 [Supported] GMRADPT call
  ; IA# 1096 [Controlled Subscription] ^DGPM("ATID1" x-ref loop
- ; IA# 358 [Controlled Subscription] FILE 405 references
  ;
 ADD(X) ; [Procedure] Add line to @RESULTS@(...
@@ -50 +51 @@
  .I +MDHL7=1 S MDFDA(702,MDIENS,.09)=5,MDFDA(702,MDIENS,.08)=""
  .D:$D(MDFDA) FILE^DIE("","MDFDA","MDERR")
- ; Patch 6 - Renal Check-In
- D:+$G(MDIENS)
- .S X=+$P(^MDD(702,+MDIENS,0),U,4) Q:'X
- .I $P(^MDS(702.01,X,0),U,6)=2 D  Q  ; Renal Check-In
- ..D CP^MDKUTLR(+MDIENS)
- ..S MDFDA(702,+MDIENS_",",.09)=5
- ..D FILE^DIE("","MDFDA","MDERR")
- ; Patch 6 - Renal Check-In
  I '$D(MDERR) S @RESULTS@(0)="1^OK" Q
  D ERROR^MDRPCU(RESULTS,.MDERR)
@@ -68 +61 @@
  ;
 GETCONS ; [Procedure] Get available consults for patient
- K ^TMP("MDTMP",$J) N MDCDT,MDDY,X1,X2,X
- S MDDY=$$GET^XPAR("SYS","MD COMPL PROC DISPLAY DAYS",1)
- S X1=DT,X2=-$S(MDDY>0:+MDDY,1:365) D C^%DTC S MDCDT=X
+ K ^TMP("MDTMP",$J)
  D CPLIST^GMRCCP(DFN,,$NA(^TMP("MDTMP",$J)))
  S MDX=0
  F  S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX  D:"saprc"[$P(^(MDX),U,4)
  .S Y="123;"_$P(^TMP("MDTMP",$J,MDX),U,5)
- .I $P($G(^TMP("MDTMP",$J,MDX)),U,4)="c" Q:$P($G(^TMP("MDTMP",$J,MDX)),U,1)<MDCDT
  .F X=2,3,4,1,6,5 S Y=Y_U_$P(^TMP("MDTMP",$J,MDX),U,X)
  .S Y=Y_U_+$O(^MDD(702,"ACON",+$P(^TMP("MDTMP",$J,MDX),U,5)))
@@ -124 +114 @@
  ;
 GETTRAN ; [Procedure] Get a patients transactions
- K ^TMP("MDTMP",$J),^TMP("MDCONL",$J) N MDCDT,MDCOM,MDMULT,MDNUM,MDREQ,MDREQDT,MDYR,X1,X2,X
- S MDNUM=$$GET^XPAR("SYS","MD DAYS TO RETAIN COM STUDY",1) S MDCOM=0
- I +MDNUM>0 S X1=DT,X2=-MDNUM D C^%DTC S MDCOM=X
- D CPLIST^GMRCCP(DFN,,$NA(^TMP("MDTMP",$J)))
- S X1=DT,X2=-365 D C^%DTC S MDCDT=X
- S MDX=0 F  S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX  D:"saprc"[$P(^(MDX),U,4)
- .I $P($G(^TMP("MDTMP",$J,MDX)),U,4)="c" Q:$P($G(^TMP("MDTMP",$J,MDX)),U,1)<MDCDT
- .S ^TMP("MDCONL",$J,$P($G(^TMP("MDTMP",$J,MDX)),U,5))=$P($G(^TMP("MDTMP",$J,MDX)),U,1)
- K ^TMP("MDTMP",$J)
  F MDX=0:0 S MDX=$O(^MDD(702,"B",DFN,+MDX))_"," Q:'MDX  D
- .Q:'$$GET1^DIQ(702,MDX,.05,"I")
- .Q:$G(^TMP("MDCONL",$J,+$$GET1^DIQ(702,MDX,.05,"I")))=""
- .S MDMULT=+$$GET1^DIQ(702,MDX,".04:.12","I")
- .S MDYR=$S(MDMULT<1:MDCOM,1:MDCDT)
- .I MDNUM Q:$$GET1^DIQ(702,MDX,.09,"I")=3&($$GET1^DIQ(702,MDX,.02,"I")<MDYR)
- .S MDREQDT="" I +$$GET1^DIQ(702,MDX,.05,"I") S MDREQDT=$G(^TMP("MDCONL",$J,+$$GET1^DIQ(702,MDX,.05,"I")))
- .I MDREQDT'="" S MDREQDT=$$FMTE^XLFDT(MDREQDT,"1P")
- .S MDREQ=$$GET1^DIQ(702,MDX,.04)_"  "_+MDX_"  (Consult #:"_$$GET1^DIQ(702,MDX,.05,"I")_$S(MDREQDT'="":" Requested: "_MDREQDT,1:"")_")"
- .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)
+ .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)
  .S Y=$O(@RESULTS@(""),-1)+1
  .S @RESULTS@(Y)="702;"_+MDX_U_Z
  S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
- K ^TMP("MDCONL",$J)
  Q
  ;
 GETVST ; [Procedure] Return list of visits
- N BEG,END,VAERR,VASD,BDT,DTM,EDT,LOC,NOW,MDQUERY,MDLST,MDTDF,STI,STS,TODAY,I,J,K,XI,XE,X
- S NOW=$$NOW^XLFDT(),TODAY=$P(NOW,".",1),MDTDF=DFN
- S BEG=$$X2FM($$GETBEG),END=$$X2FM($$GETEND)+0.2359
+ N BEG,END,VAERR,VASD,BDT,DTM,EDT,LOC,NOW,MDQUERY,MDLST,STI,STS,TODAY,I,J,K,XI,XE,X
+ S NOW=$$NOW^XLFDT(),TODAY=$P(NOW,".",1)
+ S BEG=$$X2FM("T-200"),END=$$X2FM("T")+0.2359
  S MDLST="",MDSTOP=""
  I END>NOW D   ; get future encounters, past cancels/no-shows from VADPT
@@ -179 +151 @@
  .D CLOSE^SDQ(.MDQUERY)
  N TIM,MOV,MDX0,Y,MTIM,XTYP,XLOC,XLOCI,HLOC,EARLY,DONE ; admits
- S EARLY=BEG,DONE=0 S:$G(DFN)="" DFN=MDTDF
+ S EARLY=BEG,DONE=0
  S TIM="" F  S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0  D  Q:DONE
  .S MOV=0  F  S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0  D  Q:DONE
@@ -192 +164 @@
  ..S K=0 F  S K=$O(MDLST(I,J,K)) Q:'K  D
  ...S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDLST(I,J,K)
- S:$G(DFN)="" DFN=MDTDF S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_U_($$GET1^DIQ(2,DFN_",",.1)]"")
- Q
- ;
-GETBEG() ; Get Beginning Date Range
- I $$GET^XPAR("SYS","MD APPOINT START DATE",1)>1 Q "T-"_$$GET^XPAR("SYS","MD APPOINT START DATE",1)
- Q "T-200"
-GETEND() ; Get Ending Date Range
- I $$GET^XPAR("SYS","MD APPOINT END DATE",1)>1 Q "T+"_$$GET^XPAR("SYS","MD APPOINT END DATE",1)
- Q "T"
+ S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_U_($$GET1^DIQ(2,DFN_",",.1)]"")
+ Q
+ ;
 LOGSEC ; [Procedure] Log Security
- N RES
- D NOTICE^DGSEC4(.RES,DFN,DATA,1)
- S @RESULTS@(0)=$S(+RES:"1^Logged",1:"-1^Unable to log")
+ D NOTICE^DGSEC4(.RESULTS,DFN,DATA,1)
+ S @RESULTS@(0)=$S(RESULTS:"1^Logged",1:"-1^Unable to log")
  Q
  ;
@@ -216 +181 @@
  ;
 SELECT ; [Procedure] Select patient
- ; Moved to continuation routine at MD*1.0*6 due to routine size
- D SELECT^MDRPCOP1
+ I '$D(^DPT(+$G(DFN),0))#2 S @RESULTS@(0)="-1^No such patient" Q
+ S @RESULTS@(0)="1^Required Identifiers & messages"
+ S IENS=DFN_","
+ D FILE^DID(2,,"REQUIRED IDENTIFIERS","MDIDS")
+ F MDX=0:0 S MDX=$O(MDIDS("REQUIRED IDENTIFIERS",MDX)) Q:'MDX  D
+ .S MDFLD=MDIDS("REQUIRED IDENTIFIERS",MDX,"FIELD")
+ .S MDID="$$PTID^"_$$GET1^DID(2,MDFLD,"","LABEL")
+ .S MDID=MDID_U_$$GET1^DIQ(2,IENS,MDFLD)
+ .D:MDFLD=.03
+ ..S MDID=MDID_" ("_$$GET1^DIQ(2,IENS,.033)_")"
+ ..S MDID=MDID_U_$$DOB^DPTLK1(+IENS)
+ .D:MDFLD=.09
+ ..S X=$P(MDID,U,3),X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10)
+ ..S $P(MDID,U,3)=X,$P(MDID,U,4)=$$SSN^DPTLK1(+IENS)
+ .S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDID
+ S MDID="$$PTID^"_$$GET1^DID(2,.1,"","LABEL")
+ S MDID=MDID_U_$$GET1^DIQ(2,IENS,.1)
+ S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDID
+ S MDID="$$PTID^"_$$GET1^DID(2,.101,"","LABEL")
+ S MDID=MDID_U_$$GET1^DIQ(2,IENS,.101)
+ S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDID
+ K MDRET
+ D GUIBS5A^DPTLK6(.MDRET,DFN) D:MDRET(1)=1
+ .D ADD("$$MSGHDR^2^SAME LAST NAME AND LAST 4")
+ .S MDX=1
+ .F  S MDX=$O(MDRET(MDX)) Q:'MDX!(+$G(MDRET(MDX)))  D
+ ..D ADD($P(MDRET(MDX),U,2))
+ .D ADD(" ")
+ .S MDX=1
+ .F  S MDX=$O(MDRET(MDX)) Q:'MDX  D:+MDRET(MDX)
+ ..S MDDFN=+$P(MDRET(MDX),U,2)
+ ..D ADD($$GET1^DIQ(2,MDDFN_",",.01)_"    "_$$DOB^DPTLK1(MDDFN)_"    "_$$SSN^DPTLK1(MDDFN))
+ .D ADD(" ")
+ .D ADD("Please review carefully before continuing")
+ .D ADD("$$MSGEND")
+ K MDRET
+ D PTSEC^DGSEC4(.MDRET,DFN) D:MDRET(1)'=0
+ .D:MDRET(1)=3
+ ..D ADD("$$MSGHDR^0^CAN'T ACCESS YOUR OWN RECORD!!")
+ .D:MDRET(1)=-1
+ ..D ADD("$$MSGHDR^0^INCOMPLETE INFORMATION - CAN'T PROCEED")
+ .D:MDRET(1)=1
+ ..D ADD("$$MSGHDR^1^SENSITIVE RECORD ACCESS")
+ .D:MDRET(1)'=-1&(MDRET(1)'=3)&(MDRET(1)'=1)
+ ..D ADD("$$MSGHDR^3^SENSITIVE RECORD ACCESS")
+ .S MDX=1
+ .F  S MDX=$O(MDRET(MDX)) Q:'MDX  D ADD($TR(MDRET(MDX),"*"," "))
+ .D ADD("$$MSGEND")
+ D GUIMTD^DPTLK6(.MDRET,DFN) D:MDRET(1)=1
+ .D ADD("$$MSGHDR^1^NOTICE")
+ .F MDX=1:0 S MDX=$O(MDRET(MDX)) Q:'MDX  D ADD(MDRET(MDX))
+ .D ADD("$$MSGEND")
  Q
  ;

FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDRPCOT.m

@@ -1 @@
-MDRPCOT ; HOIFO/DP/NCA - Object RPCs (TMDTransaction) ;3/12/08  09:18
- ;;1.0;CLINICAL PROCEDURES;**5,6**;Apr 01, 2004;Build 102
+MDRPCOT ; HOIFO/DP/NCA - Object RPCs (TMDTransaction) ;12/5/02  15:33
+ ;;1.0;CLINICAL PROCEDURES;**5**;Apr 01, 2004;Build 1
  ; Integration Agreements:
  ; IA# 2693 [Subscription] TIU Extractions.
@@ -22 +22 @@
  ; Sets @RESULTS@(0)="-1^Reason for not deleting" or "1^Study Deleted"
  ;
- N MDAST,MDHOLD,MDNOTE,MDRES,MDSIEN,BODY,SUBJECT,DEVIEN
+ N MDHOLD,MDNOTE,MDRES,MDSIEN
  S (MDHOLD,MDSIEN)=+DATA,MDRES=0,MDNOTE=""
- D ALERT^MDHL7U3(MDSIEN) ; Builds the body of the mail message
- I $G(^MDD(702,+MDSIEN,0))="" S @RESULTS@(0)="1^Study Deleted." D NOTICE^MDHL7U3(SUBJECT,.BODY,DEVIEN,DUZ) Q  ;deleting message
  S:+$P(^MDD(702,MDSIEN,0),U,6) MDNOTE=$P(^MDD(702,MDSIEN,0),U,6)
  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
@@ -37 +35 @@
  .Q
  E  D
- .I $D(^MDD(702.001,"ASTUDY",MDSIEN)) S @RESULTS@(0)="-1^Note associated with study, can not delete." Q
- .S MDAST=$$HL7CHK^MDHL7U3(+MDSIEN) I +MDAST<1 S @RESULTS@(0)=MDAST Q
- .D NOTICE^MDHL7U3(SUBJECT,.BODY,DEVIEN,DUZ) ; delete message
  .S MDFDA(702,DATA_",",.01)=""
- .; Check for renal study to delete as well
- .S:$D(^MDK(704.202,DATA)) MDFDA(704.202,DATA_",",.01)=""
  .D FILE^DIE("","MDFDA")
  .N DA,DIK S DA=+MDSIEN,DIK="^MDD(702," D ^DIK
@@ -58 +51 @@
  NEW MDFDA,MDIEN,MDIENS,MDRET,P1,P2,P3,P4
  S P1=$P(DATA,U,1),P2=$P(DATA,U,2),P3=$P(DATA,U,3),P4=$P(DATA,U,4)
- S MDIEN=0 I $G(^MDD(702,+P1,0))="" Q
+ S MDIEN=0
  ; Look for file (All comparisons done on lower case values)
  F  S MDIEN=$O(^MDD(702,P1,.1,MDIEN)) Q:'MDIEN  D  Q:X=P3
@@ -99 +92 @@
  S MDFDA(702,DATA,.09)=TYPE
  D FILE^DIE("","MDFDA")
- I TYPE=3&($G(^MDK(704.202,+DATA,0))'="") K MDFDA S MDFDA(704.202,DATA,.09)=0 D FILE^DIE("","MDFDA") K MDFDA
  Q
  ;
@@ -124 +116 @@
  S MDRESUL=$$NEWTIUN(MDSTUDY)
  ; File TIU Error messages
+ ;I +MDRESUL<0 D FILEMSG(MDSTUDY,"TIU",2,MDRESUL) Q MDRESUL
  I +MDRESUL<0 D  Q
  .D FILEMSG(MDSTUDY,"TIU",2,MDRESUL)
@@ -168 +161 @@
  .S MDVSTR=$$GETVSTR^MDRPCOT1(DFN,MDVSTR,MDPROC,$$GET1^DIQ(702,MDIEN,.02,"I"))
  .S MDLOC=$P(MDVSTR,";",1)
- I $$GET1^DIQ(702.01,+MDPROC_",",.12,"I")=1 Q DFN_"^"_MDTITL_"^"_MDLOC_"^^"_MDCON_"^"_MDPROC_"^"_MDVSTR_"^"_MDNVST
  ; Does TIU doc already exist?
  I $$GET1^DIQ(702,MDIEN,.06,"I") Q DFN_"^"_MDTITL_"^"_MDLOC_"^"_+$$GET1^DIQ(702,MDIEN,.06,"I")_"^"_MDCON_"^"_MDPROC_"^"_MDVSTR_"^"_MDNVST
@@ -178 +170 @@
  ; Input: STUDY - IENS of CP study entry
  ; Return: TIU Document IEN
- N CTR,DFN,MDCON,MDFDA,MDGST,MDL,MDLOC,MDNOTE,MDPDT,MDPROC,MDRESU,MDTITL,MDTSTR,MDVST,MDVSTR,MDWP,MDPT S CTR=0,MDGST=+STUDY,MDRESU=""
+ N CTR,DFN,MDCON,MDFDA,MDGST,MDL,MDLOC,MDNOTE,MDPDT,MDPROC,MDRESU,MDTITL,MDTSTR,MDVST,MDVSTR,MDWP S CTR=0,MDGST=+STUDY,MDRESU=""
  ; Get data for TIU Note Creation
  S (MDTSTR,MDRESU)=$$GETDATA(MDGST)
@@ -192 +184 @@
  ; Create new visit, if no vstring
  S MDPDT=$$PDT^MDRPCOT1(MDGST)
- I 'MDPDT S MDPT=$O(^MDD(703.1,"ASTUDYID",+MDGST,0)),MDPDT=$P($G(^MDD(703.1,+MDPT,0)),U,3)
  S:'MDPDT MDPDT=$P(MDVSTR,";",2) ; If No D/T Performed grab visit D/T
- I $P(MDVSTR,";",3)="V" S $P(MDVSTR,";",3)="A"
  ; Build variables for TIU Call
  S MDWP(.05)=1 ; Undicated Status
  S MDWP(1405)=+MDCON_";GMR(123," ; Package Reference
- S MDWP(70201)=5 ; Default Procedure Summary Code "Machine Resulted"
  I MDPDT S MDWP(70202)=MDPDT ; Date/Time Performed
  ; File PCE Error message
- I MDNVST S MDRESU=$$EN1^MDPCE(MDGST,$P(MDVSTR,";",2),MDPROC,$P(MDVSTR,";",3),"P") I +MDRESU S MDVST=+MDRESU,MDVSTR=$P(MDRESU,"^",2)
+ I MDNVST S MDRESU=$$EN1^MDPCE(MDGST,MDPDT,MDPROC,$P(MDVSTR,";",3),"P") I +MDRESU S MDVST=+MDRESU,MDVSTR=$P(MDRESU,"^",2)
  I MDNVST&(+MDRESU<0) D FILEMSG(MDGST,"PCE",2,$P(MDRESU,"^",2)) Q MDRESU
  ; Create the TIU note stub
@@ -209 +198 @@
  S MDFDA(702,STUDY_",",.06)=+MDNOTE
  S MDFDA(702,STUDY_",",.08)=""
- S:MDVST>0 MDFDA(702,STUDY_",",.13)=MDVST
  D FILE^DIE("","MDFDA")
- D UPD^MDKUTLR(STUDY,+MDNOTE)
  Q 1
  ;