MDCLIO1 ;HINES OIFO/DP - CliO backend driver (Continuation);02 Sep 2005
;;1.0;CLINICAL PROCEDURES;**16**;Apr 01, 2004;Build 280
;Per VHA Directive 2004-038, this routine should not be modified.
;
; This routine uses the following IAs:
; # 3027 - NOTICE^DGSEC4 Registration (supported)
; # 5407 - GETDCOS^ORWTPN OE/RR (controlled subscription)
; # 3568 - LNGCP^TIUCP TIU (controlled subscription)
; # 3535 - TIUSRVP calls TIU (controlled subscription)
; # 1800 - REQCOS^TIUSRVA TIU (controlled subscription)
; # 2876 - LONGLIST^TIUSRVD TIU (controlled subscription)
; # 2263 - XPAR calls Toolkit (supported)
; #10045 - HASH^XUSHSHP Kernel (supported)
; # 2240 - ENCRYP^XUSRB1 Kernel (supported)
; # 2241 - DECRYP^XUSRB1 Kernel (supported)
; # 4866 - access ^GMRD(120.51,"AVUID" Vitals (private)
; # 4114 - access ^PXRMINDX(120.5 Clinical Reminders (controlled subscription)
; #10040 - access ^SC( Scheduling (supported)
;
GETPT ; Does an old style lookup on file 2 so that we don't have to use a PK
D FIND^DIC(2,,.01,"KMP",P2(0),"*")
F X=0:0 S X=$O(^TMP("DILIST",$J,X)) Q:'X S @MDROOT@(+^(X,0))=""
Q
GETESIG ; Returns record with boolean of proper E-Sig entered
D NEWDOC^MDCLIO("RESULTS","ESIG-VALIDATION")
D XMLHDR^MDCLIO("RECORD")
D XMLDATA^MDCLIO("EXTERNAL",P2(0))
S X=$G(P2(0)) D HASH^XUSHSHP S MDX=X
D XMLDATA^MDCLIO("INTERNAL",MDX)
D XMLDATA^MDCLIO("VALID",MDX=$$GET1^DIQ(200,DUZ_",",20.4,"I"))
D XMLFTR^MDCLIO("RECORD")
D ENDDOC^MDCLIO("RESULTS")
Q
GETKRDXA(MDPT,MDSTRT,MDSTOP) ; Returns all actions for patient MDPT active between MDSTRT & MDSTOP
Q
GETKRDXE(MDTASK,MDSTRT,MDSTOP) ; Returns all events for Kardex Action MDTASK active between MDSTRT & MDSTOP
Q
GETGUID(X) ; Returns a string formatted as a GUID (NO GUARANTEE OF UNIQUENESS)
S X=""
F S X=X_$$BASE^XLFUTL($R(16),10,16) Q:$L(X)>31
S X="{"_$E(X,1,8)_"-"_$E(X,9,12)_"-"_$E(X,13,16)_"-"_$E(X,17,20)_"-"_$E(X,21,32)_"}"
Q
ISGUID(MDX) ; Returns true if X is in the format of a GUID
N X,Y
Q:$L(MDX)'=38 0
Q:MDX'?1"{"8UN1"-"4UN1"-"4UN1"-"4UN1"-"12UN1"}" 0
; Scan for Uppercase character above F
X "S X=1 F Y=71:1:90 I MDX[$C(Y) S X=0 Q"
Q X
;
PXRMALL ; Full rebuild of the Clinical Reminders Index - Only Verified sent for rebuild
F MD=0:0 S MD=$O(^MDC(704.117,MD)) Q:'MD D:$P(^(MD,0),U,9)=1 PXRMONE(MD)
Q
PXRMONE(MDIEN) ; Maintain the Clinical Reminders Index
N MDVUID,MDVITAL,MDGBL,MDDFN,MDDT,MDSTAT
S MDVUID=$$GET1^DIQ(704.117,MDIEN_",",".07:99.99","I") Q:MDVUID=""
S MDVITAL=$O(^GMRD(120.51,"AVUID",MDVUID,0)) Q:'MDVITAL
S MDGUID=$P(^MDC(704.117,MDIEN,0),U),MDDFN=$P(^(0),U,8),MDDT=$P(^(0),U,5),MDSTAT=$P(^(0),U,9)
Q:MDGUID=""!('MDDFN)!('MDDT) ; Just in case :)
S MDGBL=$NA(^PXRMINDX(120.5))
I MDSTAT=1 D
.S @MDGBL@("PI",MDDFN,MDVITAL,MDDT,MDGUID)=""
.S @MDGBL@("IP",MDVITAL,MDDFN,MDDT,MDGUID)=""
E D
.K @MDGBL@("PI",MDDFN,MDVITAL,MDDT,MDGUID)
.K @MDGBL@("IP",MDVITAL,MDDFN,MDDT,MDGUID)
Q
LOGSEC ; Logs a security hit in PIMS
D NOTICE^DGSEC4(.MDRET,P2(0))
S @RESULTS@(0)=$S(MDRET:"1^Logged",1:"-1^Unable to log")
Q
GETTIUCP ; Gets a list of CP Class TIU notes - bypass regular lookup stuff and call directly
N MDRET K @RESULTS
S MDDATA=$$UP^XLFSTR(P2(0))
D NEWDOC^MDCLIO("RESULTS","VERSION INFORMATION")
D LNGCP^TIUCP(.MDRET,MDDATA)
I $D(MDRET(44)),$P($P(MDRET(44),U,2),$$UP^XLFSTR(P2(0)))="" D XMLFTR^MDCLIO("RESULTS") Q
F Y=0:0 S Y=$O(MDRET(Y)) Q:'Y D:$P(MDRET(Y),U,2)?@("1"""_MDDATA_""".E")
.D XMLHDR^MDCLIO("RECORD")
.D XMLDATA^MDCLIO("ID",$P(MDRET(Y),U,1))
.D XMLDATA^MDCLIO("NAME",$P(MDRET(Y),U,2))
.D XMLFTR^MDCLIO("RECORD")
K MDDATA
D ENDDOC^MDCLIO("RESULTS")
Q
GETTIUPN ; Gets list of all Progress Note Titles
N MDRET K @RESULTS
S MDDATA=$$UP^XLFSTR(P2(0))
D NEWDOC^MDCLIO("RESULTS","VERSION INFORMATION")
D LONGLIST^TIUSRVD(.MDRET,3,MDDATA)
I $D(MDRET(44)),$P($P(MDRET(44),U,2),$$UP^XLFSTR(P2(0)))="" D XMLFTR^MDCLIO("RESULTS") Q
F Y=0:0 S Y=$O(MDRET(Y)) Q:'Y D:$P(MDRET(Y),U,2)?@("1"""_MDDATA_""".E")
.D XMLHDR^MDCLIO("RECORD")
.D XMLDATA^MDCLIO("ID",$P(MDRET(Y),U,1))
.D XMLDATA^MDCLIO("NAME",$P(MDRET(Y),U,2))
.D XMLFTR^MDCLIO("RECORD")
K MDDATA
D ENDDOC^MDCLIO("RESULTS")
Q
GETUSER ; Gets the current users record in ^VA(200,
S MDROOT="MDROOT"
S MDROOT(DUZ)=""
Q
GETLST ; Get a list of observations sent down in P2(0..n)=ID
S MDROOT=$NA(^TMP("MDCLIO",$J)) K @MDROOT
S MDID=""
F S MDID=$O(P2(MDID)) Q:MDID="" D:P2(MDID)]""
.S X=$O(^MDC(704.117,"PK",P2(MDID),0)) S:X @MDROOT@(0,X)=""
Q
GETONE(ID) ; Get single Observation + Children if any
S X=$$FIND1^DIC(704.117,,"KXP",ID(0))
Q:'X S @MDROOT@(0,X)=""
F Y=0:0 S Y=$O(^MDC(704.117,"AP",X,Y)) Q:'Y S @MDROOT@(Y,$O(^MDC(704.117,"AP",X,Y,0)))=""
Q
LOCATION ; Get list of wards, clinics and non-stops
N MDNOW D NOW^%DTC S MDNOW=%
S MDROOT=$NA(^TMP("MDCLIO",$J)) K @MDROOT
F X=0:0 S X=$O(^SC(X)) Q:'X D:"CWN"[$P(^(X,0),U,3)
.I '+$G(^SC(X,"I")) S @MDROOT@(X)="" Q ; No deactivation date on file
.I +^SC(X,"I")<MDNOW&('$P(^("I"),U,2)) Q ; No reactivation date
.I +^SC(X,"I")<MDNOW&($P(^("I"),U,2)>MDNOW) Q ; future reactivation date
.S @MDROOT@(X)=""
Q
;
GETSUPPG ; Get list of supplemental/optional pages for a date range
; P2(0)=Patient DFN
; P2(1)=Start Date
; P2(2)=Stop Date
S MDDFN=P2(0),MDDT=P2(2)+.0000001,MDROOT=$NA(^TMP("MDCLIO",$J)) K @MDROOT
S MDFR=$$FMDT^MDCLIO(P2(1))
S MDDT=$$FMDT^MDCLIO(P2(2))+.0000001
F S MDDT=$O(^MDC(704.1122,"ADT",MDDFN,MDDT),-1) Q:'MDDT D
.S MDIEN="" F S MDIEN=$O(^MDC(704.1122,"ADT",MDDFN,MDDT,MDIEN),-1) Q:'MDIEN D
..I $G(^MDC(704.1122,MDIEN,.2)) Q:$G(^(.2))<MDFR ; Deactivated before start date
..I +$G(^MDC(704.1122,MDIEN,.2))&($P($G(^MDC(704.1122,MDIEN,.1)),U,4)=1) Q ; Deactivated Optional Page
..S @MDROOT@(MDIEN)=""
Q
GETHL7(ID) ; Get text of HL7 Message from 704.002 entry
S IEN=+$$FIND1^DIC(704.002,,"KX",ID)
D XMLHDR^MDCLIO("HL7_TEXT")
D:IEN>0
.D GETMSG^MDCPHL7B(.MDRET,IEN)
.S X=MDRET F S X=$Q(@X) Q:$E(X,1,$L(MDRET)-1)'=$E(MDRET,1,$L(MDRET)-1) D
..D XMLADD^MDCLIO($$XMLSAFE^MDCLIO(@X))
D XMLFTR^MDCLIO("HL7_TEXT")
Q
SETACL ; Sets the ACL for an Item
D SETACL^MDCLIO
Q
;
DELACL ; Removes and item from ACL
D DELACL^MDCLIO
Q
;
SUBMIT ; Submits an HL7 message back to the queue
N MDMSG,MDSTAT
S MDMSG=$$FIND1^DIC(704.002,,"KX",P2(0))
I MDMSG<1 S @RESULTS@(0)="-1^NO SUCH MESSAGE" Q
S MDSTAT=$G(P2(1),3) ; Default to error if you didn't get a status
D UPDATERP^MDCPHL7B(.MDRET,MDMSG,MDSTAT)
S @RESULTS@(0)="1^Submitted"
Q
QRYDATE(MDRET,MDSTRT,MDSTOP) ; Get list of all observations by DATE/TIME
K @MDRET
F X=MDSTRT-.0000001:0 S X=$O(^MDC(704.117,"ADT",X)) Q:'X!(X>MDSTOP) D
.F Y=0:0 S Y=$O(^MDC(704.117,"ADT",X,Y)) Q:'Y D
..Q:$P(^MDC(704.117,Y,0),U,9)'=1
..S @MDRET@($O(@MDRET@(""),-1)+1)=$P(^MDC(704.117,Y,0),U)
S @MDRET@(0)=+$O(@MDRET@(""),-1)
Q
QRYLST(MDRET,MDDFN,MDITEM,MDSTRT,MDSTOP) ; Get list of observations by VUID or TERM NAME
N MDTERM
K @MDRET
S MDSTRT=$G(MDSTRT,DT\1) ; Default today @00:00
S MDSTOP=$G(MDSTOP,DT\1+.24) ; Default today @24:00
S MDTERM=$$FIND1^DIC(704.101,"","PKMX",MDITEM,"C^VUID","I $P(^(0),U,5)=1")
I MDTERM<1 S @MDRET@(0)="-1^Cannot find term '"_MDITEM_"'" Q
F X=MDSTRT-.0000001:0 S X=$O(^MDC(704.117,"PT",MDDFN,X)) Q:'X!(X>MDSTOP) D
.F Y=0:0 S Y=$O(^MDC(704.117,"PT",MDDFN,X,Y)) Q:'Y D
..Q:$P(^MDC(704.117,Y,0),U,9)'=1
..Q:$P(^MDC(704.117,Y,0),U,7)'=MDTERM
..S @MDRET@($O(@MDRET@(""),-1)+1)=$P(^MDC(704.117,Y,0),U)
S @MDRET@(0)=+$O(@MDRET@(""),-1)
Q
;
QRYOBS(MDRET,MDID) ; Return a single observation
N MDTMP
K @MDRET
S MDIEN=$$FIND1^DIC(704.117,"","PKX",MDID,"PK")
I MDIEN<1 S @MDRET@(0)="-1^No such observation '"_MDID_"'" Q
D GETS^DIQ(704.117,MDIEN_",","*","EIR","MDTMP")
M @MDRET=MDTMP(704.117,MDIEN_",") K MDTMP
S @MDRET@("TERM_ID","I")=$$GET1^DIQ(704.117,MDIEN_",",".07:99.99")
S @MDRET@("TERM_ID","E")=$$GET1^DIQ(704.117,MDIEN_",",".07:.02")
D:$$GET1^DIQ(704.117,MDIEN_",",".07:.06","I")=3 ; Coded data values
.S MDTMP=$$FIND1^DIC(704.101,"","PKX",@MDRET@("SVALUE","I"),"PK")
.S @MDRET@("SVALUE","E")=$$GET1^DIQ(704.101,MDTMP_",",.02)
D QRYQUAL(MDRET,MDIEN)
D QRYCTX($NA(@MDRET@("CONTEXT")),MDID)
Q
;
QRYQUAL(MDRET,MDIEN) ; Returns the qualifiers for obs in MDIEN
N MDQUAL
F Y=0:0 S Y=$O(^MDC(704.118,"PK",MDIEN,Y)) Q:'Y D
.S MDQUAL=$$GET1^DIQ(704.101,Y_",",".05:.02")
.S @MDRET@(MDQUAL,"I")=$$GET1^DIQ(704.101,Y_",","99.99")
.S @MDRET@(MDQUAL,"E")=$$GET1^DIQ(704.101,Y_",",".02")
Q
;
QRYCTX(MDRET,MDID) ; We need a terminology based context observation relationship here
N MDIEN,MDCTX,MDDT,MDFROM,MDTO,MDDFN,MDTERM,MDCNT,MDXID
S MDIEN=+$$FIND1^DIC(704.117,"","PKX",MDID,"PK") Q:MDIEN<1
S MDCTX=$$GET1^DIQ(704.117,MDIEN_",",.07) ; GET THE PRIMARY TERM (GUID)
; FILTER OUT EVERYTHING BUT SpO2 for now
Q:MDCTX'="{5F84DD55-3CCF-094C-2536-B51EB7FAD999}"
S MDDFN=+$$GET1^DIQ(704.117,MDIEN_",",.08,"I") ; GET THE PATIENT
S MDDT=+$$GET1^DIQ(704.117,MDIEN_",",.05,"I") ; GET THE OBS DATE
S MDFROM=$$FMADD^XLFDT(MDDT,0,0,0,-30) ; PREVIOUS 30 SECONDS
S MDTO=$$FMADD^XLFDT(MDDT,0,0,0,30) ; NEXT 30 SECONDS
; Now we find the context observations
F MDDT=MDFROM:0 S MDDT=$O(^MDC(704.117,"PT",MDDFN,MDDT)) Q:'MDDT!(MDDT>MDTO) D
.F MDOBS=0:0 S MDOBS=$O(^MDC(704.117,"PT",MDDFN,MDDT,MDOBS)) Q:'MDOBS D
..Q:$$GET1^DIQ(704.117,MDOBS_",",.09,"I")'=1 ; Verfied Only
..S MDXID=$$GET1^DIQ(704.117,MDOBS_",",.01)
..Q:MDXID=MDID ; You should ignore yourself in this loop
..S MDTERM=$$GET1^DIQ(704.117,MDOBS_",",".07")
..; INSERT FILTER CODE FOR O2 Flowrate and Concentration here - In the future we will find all context terms for an observation in terminology
..Q:(MDTERM'="{56F82CAC-3564-46CE-A520-1025020DADE9}")&(MDTERM'="{3BB314E8-9BBB-480E-B34E-B56EDE43BAC4}")
..S MDCNT=$O(@MDRET@(""),-1)+1,@MDRET@(0)=MDCNT
..S @MDRET@(MDCNT,"OBS_ID","I")=MDXID
..S @MDRET@(MDCNT,"OBS_ID","E")=MDXID
..S @MDRET@(MDCNT,"TERM_ID","I")=$$GET1^DIQ(704.117,MDOBS_",",".07:99.99")
..S @MDRET@(MDCNT,"TERM_ID","E")=$$GET1^DIQ(704.117,MDOBS_",",".07:.02")
..S @MDRET@(MDCNT,"SVALUE","I")=$$GET1^DIQ(704.117,MDOBS_",",".1","I")
..S @MDRET@(MDCNT,"SVALUE","E")=$$GET1^DIQ(704.117,MDOBS_",",".1","E")
..D QRYQUAL($NA(@MDRET@(MDCNT)),MDOBS)
Q
GETOBS(MDPAR) ; Get list of observations by date
S MDPT=MDPAR(0)
S MDROOT=$NA(^TMP("MDCLIO",$J)) K @MDROOT
S MDFR=$$FMDT^MDCLIO(MDPAR(1))-.0000001
S MDTO=$$FMDT^MDCLIO(MDPAR(2))\1+.235959
F S MDFR=$O(^MDC(704.117,"PT",MDPT,MDFR)) Q:'MDFR!(MDFR>MDTO) D
.F Y=0:0 S Y=$O(^MDC(704.117,"PT",MDPT,MDFR,Y)) Q:'Y S @MDROOT@(Y)=""
Q
GETBYDT ; Get list of observations by date
S MDPT=P2(0)
S MDROOT=$NA(^TMP("MDCLIO",$J)) K @MDROOT
S MDFR=$$FMDT^MDCLIO(P2(1))-.0000001
S MDTO=$$FMDT^MDCLIO(P2(2))
F S MDFR=$O(^MDC(704.117,"PT",MDPT,MDFR)) Q:'MDFR!(MDFR>MDTO) D
.F Y=0:0 S Y=$O(^MDC(704.117,"PT",MDPT,MDFR,Y)) Q:'Y S @MDROOT@(Y)=""
Q
GETLOG ; Get list of date/time pairs with data
S MDPT=P2(0),MDROOT=$NA(^TMP("MDCLIO",$J)) K @MDROOT
S MDFR=$$FMDT^MDCLIO(P2(1))-.0000001
S MDTO=$$FMDT^MDCLIO(P2(2))
S MDSTAT=""
F S MDSTAT=$O(^MDC(704.117,"AS",MDSTAT)) Q:MDSTAT="" D
.S MDDT=MDFR
.F S MDDT=$O(^MDC(704.117,"AS",MDSTAT,MDPT,MDDT)) Q:'MDDT!(MDDT>MDTO) D
..S @MDROOT@(MDSTAT,MDDT,$O(^MDC(704.117,"AS",MDSTAT,MDPT,MDDT,0)))=""
Q
GETBYST ; Get list of observations by patient, status, and date range
S MDPT=P2(0),MDSTAT=P2(3),MDROOT=$NA(^TMP("MDCLIO",$J)) K @MDROOT
S MDFR=$$FMDT^MDCLIO(P2(1))-.0000001
S MDTO=$$FMDT^MDCLIO(P2(2))
F S MDFR=$O(^MDC(704.117,"AS",MDSTAT,MDPT,MDFR)) Q:'MDFR!(MDFR>MDTO) D
.F Y=0:0 S Y=$O(^MDC(704.117,"AS",MDSTAT,MDPT,MDFR,Y)) Q:'Y S @MDROOT@(Y)=""
Q
AUDIT(Y) ; Looks up the audit records for an observation in external format
S MDROOT=$NA(^MDC(704.119,"ALOG",+$O(^MDC(704.117,"PK",Y,0))))
Q
QUAL ; Retrieves all qualifiers for an observation - MDIENS = iens of observation from MDCLIO
N MDQUAL
F MDQUAL=0:0 S MDQUAL=$O(^MDC(704.118,"PK",+MDIENS,MDQUAL)) Q:'MDQUAL D
.D XMLDATA^MDCLIO($$GET1^DIQ(704.101,MDQUAL_",",".05:.02","I"),$$GET1^DIQ(704.101,MDQUAL_",",".01","I"))
Q
SETS ; Retrieve the sets this observation belongs to
D XMLHDR^MDCLIO("SETS")
N MDSET F MDSET=0:0 S MDSET=$O(^MDC(704.1161,"AS",+MDIENS,MDSET)) Q:'MDSET D
.F MDX=0:0 S MDX=$O(^MDC(704.1161,"AS",+MDIENS,MDSET,MDX)) Q:'MDX D
..D XMLHDR^MDCLIO("SET")
..D XMLDATA^MDCLIO("VALUE",$$GET1^DIQ(704.1161,MDX_",",.01))
..D XMLFTR^MDCLIO("SET")
D XMLFTR^MDCLIO("SETS")
Q
GETQUAL ; Returns qualifiers of type P2(1) for term P2(0)
; Set Y to the IEN of the Term
S X=$$FIND1^DIC(704.101,"","KX",P2(0))
S MDROOT=$NA(^TMP("MDCLIO",$J)) K @MDROOT
S MDGBL=$NA(^MDC(704.103,"PK",X))
F S MDGBL=$Q(@MDGBL) Q:MDGBL="" Q:$QS(MDGBL,3)'=X D
.I $P(^MDC(704.101,$QS(MDGBL,5),0),U,5)=P2(1) D
..S @MDROOT@($QS(MDGBL,4),$QS(MDGBL,6))=""
Q
PROCIEN(Y) ; Converts CP DEFINITION (procedure) name to IEN
Q $$FIND1^DIC(702.01,,"KXP",Y)
INSTIEN(Y) ; Converts CP INSTRUMENT name to IEN
Q $$FIND1^DIC(702.09,,"KXP",Y)
GETINST ; Gathers instruments for a procedure
S X=$$PROCIEN(P2(0))
F Y=0:0 S Y=$O(^MDS(702.01,+X,.1,"B",Y)) Q:'Y S @MDROOT@(Y)=""
Q
ADDINST ; Adds an instrument definition to a procedure
; This is a legacy multiple in file 702.01 so it has to be done in an odd way
N MDPROC,MDINST
S MDPROC=$$PROCIEN(P2(0))
S MDINST=$$INSTIEN(P2(1))
I '+MDPROC S @RESULTS@(0)="-1^Unable to find procedure "_P2(0)
I '+MDINST S @RESULTS@(0)="-1^Unable to find instrument "_P2(1)
S MDFDA(702.011,"+1,"_MDPROC_",",.01)=MDINST
D UPDATE^DIE("","MDFDA")
S @RESULTS@(0)="1^Instrument added."
Q
DELINST ; Deletes all instruments from a procedure definition
; This is a legacy multiple in file 702.01 so it has to be done in an odd way
N MDPROC
S MDPROC=$$PROCIEN(P2(0))
F X=0:0 S X=$O(^MDS(702.01,MDPROC,.1,X)) Q:'X S MDFDA(702.011,X_","_MDPROC_",",.01)="@"
D FILE^DIE("","MDFDA")
S @RESULTS@(0)="1^Instrument list cleared."
Q
GETVER ; Get Version Information
D NEWDOC^MDCLIO("RESULTS","VERSION INFORMATION")
I $G(P2(0))="" D GETLST^XPAR(.MDRET,"SYS","MD VERSION INFORMATION","Q")
I $G(P2(0))]"" S MDRET(1)=P2(0)_"^"_$$GET^XPAR("SYS","MD VERSION INFORMATION",P2(0),"Q")
; Switch the lines below once we are really checking versions
;F MDRET=0:0 S MDRET=$O(MDRET(MDRET)) Q:'MDRET D:$P(MDRET(MDRET),"^",2)]""
F MDRET=0:0 S MDRET=$O(MDRET(MDRET)) Q:'MDRET D
.D XMLHDR^MDCLIO("RECORD")
.S MDVER=$P(MDRET(MDRET),"^",1)
.D XMLDATA^MDCLIO("VERSION",MDVER)
.S MDVER=$P(MDRET(MDRET),"^",2)
.; Switch the lines below once we are really checking versions
.;D XMLDATA^MDCLIO("COMPATIBLE",+MDVER)
.D XMLDATA^MDCLIO("COMPATIBLE",1)
.D XMLDATA^MDCLIO("CRC32",$P(MDVER,";",2))
.D XMLDATA^MDCLIO("PRODUCTION_RELEASE",+$P(MDVER,";",3))
.D XMLDATA^MDCLIO("COMMENT",$P(MDVER,";",4))
.D XMLFTR^MDCLIO("RECORD")
D ENDDOC^MDCLIO("RESULTS")
Q
GETVF ; Get View Filters
N MDVIEW,MDTERM,MDIEN,MDXROOT
S MDXROOT=$NA(^TMP("MDXQUERY",$J)) K @MDXROOT
S MDVIEW=+$O(^MDC(704.111,"PK",P2(0),0))
F MDTERM=0:0 S MDTERM=$O(^MDC(704.1112,"PK",MDVIEW,P2(1),MDTERM)) Q:'MDTERM D
.F MDIEN=0:0 S MDIEN=$O(^MDC(704.1112,"PK",MDVIEW,P2(1),MDTERM,MDIEN)) Q:'MDIEN S @MDXROOT@(MDIEN)=MDIEN
D XQUERY^MDCLIO
Q
NEWNOTE ; Returns a new note ID
D GETGUID(.MD)
K ^TMP("MDNOTE",$J,MD)
D QUICKDOC^MDCLIO("ID",MD)
Q
CLRNOTE ; Clears any text in a temporary note P2(0)=Temporary ID
K ^TMP("MDNOTE",$J,P2(0))
S @RESULTS@(0)="1^Note Cleared"
Q
ADDTEXT ; Adds P2(1..n) to the note in P2(0)
F X=0:0 S X=$O(P2(X)) Q:'X D
.S Y=$O(^TMP("MDNOTE",$J,P2(0),""),-1)+1
.S ^TMP("MDNOTE",$J,P2(0),Y,0)=P2(X)
S @RESULTS@(0)=$O(P2(""),-1)_"^Lines added"
Q
;
SENDMAIL ; Sends an EMail Message
D SENDMAIL^MDCLIO
;
GETTIU ; Gets Privs for note title in P2(0)
N MDRET
D NEWDOC^MDCLIO("RESULTS","TIU PRIVS")
D XMLHDR^MDCLIO("RECORD")
D REQCOS^TIUSRVA(.MDRET,P2(0))
D XMLDATA^MDCLIO("REQUIRE_COSIGN",MDRET)
D GETDCOS^ORWTPN(.MDRET,DUZ)
D:+MDRET
.D XMLDATA^MDCLIO("DEF_COSIGN_ID",$P(MDRET,U,1))
.D XMLDATA^MDCLIO("DEF_COSIGN_NAME",$P(MDRET,U,2))
D XMLFTR^MDCLIO("RECORD")
D ENDDOC^MDCLIO()
Q
;
SIGNTIU ; Signs the note
N MDNOW,MDESIG,MDNOTE,MDTEXT,MDVAU,MDRET
D NOW^%DTC S MDNOW=%
S MDESIG=$$DECRYP^XUSRB1(P2(4)),MDESIG=$$ENCRYP^XUSRB1(MDESIG)
D MAKE^TIUSRVP(.MDNOTE,P2(1),P2(2),MDNOW,P2(3))
I MDNOTE<1 S @RESULTS@(0)="-1^Unable to create note." Q
S MDTEXT(2)=$NA(^TMP("MDNOTE",$J,P2(0)))
; Check for a co-signer
I +$G(P2(5)) S MDTEXT(1506)=1,MDTEXT(1208)=+$G(P2(5))
D UPDATE^TIUSRVP(.MDRET,+MDNOTE,.MDTEXT,1)
I MDRET<1 S @RESULTS@(0)="-1^Unable to file note text." Q
D SIGN^TIUSRVP(.MDRET,MDNOTE,MDESIG)
K MDESIG
I MDRET<0 S @RESULTS@(0)="-1^Unable to sign the note." Q
S @RESULTS@(0)="1^Note signed and filed."
Q
;
GETENT(X) ; Returns the entity path upward
Q X_$P("USR^DIV^SYS",X,2)
;
OPENPAR ; Opens and verifies a parameter Entity
D NOW^%DTC S %=%+.00000001
S Y=($E(%,1,3)+1700)_"-"_$E(%,4,5)_"-"_$E(%,6,7)_" "_$E(%,9,10)_":"_$E(%,11,12)_":"_$E(%,13,14)
D EN^XPAR("USR",P2(0),"Date/Time Last Accessed",Y,.MDERR)
I 'MDERR S @RESULTS@(0)="1" E S @RESULTS@(0)=MDERR
Q
LSTPAR ; Returns all parameter Values as a Query
; GETLST^XPAR(.List,Entity,Parameter,Format,.Error)
N MDLST,MDENT,MDNAME
D NEWDOC^MDCLIO("RESULTS")
D GETLST^XPAR(.MDRET,P2(0),P2(1),"Q",.MDERR)
F Y=0:0 S Y=$O(MDRET(Y)) Q:'Y S MDLST($P(MDRET(Y),U,1))=$P(MDRET(Y),U,2,250)
K MDRET
D:'MDERR
.S MDNAME="" F S MDNAME=$O(MDLST(MDNAME)) Q:MDNAME="" D
..D XMLHDR^MDCLIO("RECORD")
..D XMLDATA^MDCLIO("NAME",MDNAME)
..D XMLDATA^MDCLIO("VALUE",MDLST(MDNAME))
..D XMLFTR^MDCLIO("RECORD")
D ENDDOC^MDCLIO("RESULTS")
Q
CLRPAR ; Clears all settings for an entity
D NDEL^XPAR(P2(0),P2(1),.MDERR)
I 'MDERR S @RESULTS@(0)=1 E S @RESULTS@(0)=MDERR
Q
SETPAR ; Sets a single parameter value
N MDVALUE
S MDVALUE=$G(P2(3),"@") S:MDVALUE="" MDVALUE="@"
D STRIP^MDCLIO(MDVALUE)
I MDVALUE="@" D Q
.D DEL^XPAR(P2(0),P2(1),P2(2),.MDERR)
.S @RESULTS@(0)=1
D EN^XPAR(P2(0),P2(1),P2(2),MDVALUE,.MDERR)
S @RESULTS@(0)='MDERR
Q
GETPAR ; Gets a single parameter value
N MDVALUE
D NEWDOC^MDCLIO("RESULTS")
D XMLHDR^MDCLIO("RECORD")
S MDVALUE=$$GET^XPAR(P2(0),P2(1),P2(2),"Q")
D:MDVALUE]"" XMLDATA^MDCLIO("VALUE",MDVALUE)
D XMLFTR^MDCLIO("RECORD")
D ENDDOC^MDCLIO("RESULTS")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMDCLIO1 19151 printed Oct 16, 2024@17:43:13 Page 2
MDCLIO1 ;HINES OIFO/DP - CliO backend driver (Continuation);02 Sep 2005
+1 ;;1.0;CLINICAL PROCEDURES;**16**;Apr 01, 2004;Build 280
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; This routine uses the following IAs:
+5 ; # 3027 - NOTICE^DGSEC4 Registration (supported)
+6 ; # 5407 - GETDCOS^ORWTPN OE/RR (controlled subscription)
+7 ; # 3568 - LNGCP^TIUCP TIU (controlled subscription)
+8 ; # 3535 - TIUSRVP calls TIU (controlled subscription)
+9 ; # 1800 - REQCOS^TIUSRVA TIU (controlled subscription)
+10 ; # 2876 - LONGLIST^TIUSRVD TIU (controlled subscription)
+11 ; # 2263 - XPAR calls Toolkit (supported)
+12 ; #10045 - HASH^XUSHSHP Kernel (supported)
+13 ; # 2240 - ENCRYP^XUSRB1 Kernel (supported)
+14 ; # 2241 - DECRYP^XUSRB1 Kernel (supported)
+15 ; # 4866 - access ^GMRD(120.51,"AVUID" Vitals (private)
+16 ; # 4114 - access ^PXRMINDX(120.5 Clinical Reminders (controlled subscription)
+17 ; #10040 - access ^SC( Scheduling (supported)
+18 ;
GETPT ; Does an old style lookup on file 2 so that we don't have to use a PK
+1 DO FIND^DIC(2,,.01,"KMP",P2(0),"*")
+2 FOR X=0:0
SET X=$ORDER(^TMP("DILIST",$JOB,X))
if 'X
QUIT
SET @MDROOT@(+^(X,0))=""
+3 QUIT
GETESIG ; Returns record with boolean of proper E-Sig entered
+1 DO NEWDOC^MDCLIO("RESULTS","ESIG-VALIDATION")
+2 DO XMLHDR^MDCLIO("RECORD")
+3 DO XMLDATA^MDCLIO("EXTERNAL",P2(0))
+4 SET X=$GET(P2(0))
DO HASH^XUSHSHP
SET MDX=X
+5 DO XMLDATA^MDCLIO("INTERNAL",MDX)
+6 DO XMLDATA^MDCLIO("VALID",MDX=$$GET1^DIQ(200,DUZ_",",20.4,"I"))
+7 DO XMLFTR^MDCLIO("RECORD")
+8 DO ENDDOC^MDCLIO("RESULTS")
+9 QUIT
GETKRDXA(MDPT,MDSTRT,MDSTOP) ; Returns all actions for patient MDPT active between MDSTRT & MDSTOP
+1 QUIT
GETKRDXE(MDTASK,MDSTRT,MDSTOP) ; Returns all events for Kardex Action MDTASK active between MDSTRT & MDSTOP
+1 QUIT
GETGUID(X) ; Returns a string formatted as a GUID (NO GUARANTEE OF UNIQUENESS)
+1 SET X=""
+2 FOR
SET X=X_$$BASE^XLFUTL($RANDOM(16),10,16)
if $LENGTH(X)>31
QUIT
+3 SET X="{"_$EXTRACT(X,1,8)_"-"_$EXTRACT(X,9,12)_"-"_$EXTRACT(X,13,16)_"-"_$EXTRACT(X,17,20)_"-"_$EXTRACT(X,21,32)_"}"
+4 QUIT
ISGUID(MDX) ; Returns true if X is in the format of a GUID
+1 NEW X,Y
+2 if $LENGTH(MDX)'=38
QUIT 0
+3 if MDX'?1"{"8UN1"-"4UN1"-"4UN1"-"4UN1"-"12UN1"}"
QUIT 0
+4 ; Scan for Uppercase character above F
+5 XECUTE "S X=1 F Y=71:1:90 I MDX[$C(Y) S X=0 Q"
+6 QUIT X
+7 ;
PXRMALL ; Full rebuild of the Clinical Reminders Index - Only Verified sent for rebuild
+1 FOR MD=0:0
SET MD=$ORDER(^MDC(704.117,MD))
if 'MD
QUIT
if $PIECE(^(MD,0),U,9)=1
DO PXRMONE(MD)
+2 QUIT
PXRMONE(MDIEN) ; Maintain the Clinical Reminders Index
+1 NEW MDVUID,MDVITAL,MDGBL,MDDFN,MDDT,MDSTAT
+2 SET MDVUID=$$GET1^DIQ(704.117,MDIEN_",",".07:99.99","I")
if MDVUID=""
QUIT
+3 SET MDVITAL=$ORDER(^GMRD(120.51,"AVUID",MDVUID,0))
if 'MDVITAL
QUIT
+4 SET MDGUID=$PIECE(^MDC(704.117,MDIEN,0),U)
SET MDDFN=$PIECE(^(0),U,8)
SET MDDT=$PIECE(^(0),U,5)
SET MDSTAT=$PIECE(^(0),U,9)
+5 ; Just in case :)
if MDGUID=""!('MDDFN)!('MDDT)
QUIT
+6 SET MDGBL=$NAME(^PXRMINDX(120.5))
+7 IF MDSTAT=1
Begin DoDot:1
+8 SET @MDGBL@("PI",MDDFN,MDVITAL,MDDT,MDGUID)=""
+9 SET @MDGBL@("IP",MDVITAL,MDDFN,MDDT,MDGUID)=""
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 KILL @MDGBL@("PI",MDDFN,MDVITAL,MDDT,MDGUID)
+12 KILL @MDGBL@("IP",MDVITAL,MDDFN,MDDT,MDGUID)
End DoDot:1
+13 QUIT
LOGSEC ; Logs a security hit in PIMS
+1 DO NOTICE^DGSEC4(.MDRET,P2(0))
+2 SET @RESULTS@(0)=$SELECT(MDRET:"1^Logged",1:"-1^Unable to log")
+3 QUIT
GETTIUCP ; Gets a list of CP Class TIU notes - bypass regular lookup stuff and call directly
+1 NEW MDRET
KILL @RESULTS
+2 SET MDDATA=$$UP^XLFSTR(P2(0))
+3 DO NEWDOC^MDCLIO("RESULTS","VERSION INFORMATION")
+4 DO LNGCP^TIUCP(.MDRET,MDDATA)
+5 IF $DATA(MDRET(44))
IF $PIECE($PIECE(MDRET(44),U,2),$$UP^XLFSTR(P2(0)))=""
DO XMLFTR^MDCLIO("RESULTS")
QUIT
+6 FOR Y=0:0
SET Y=$ORDER(MDRET(Y))
if 'Y
QUIT
if $PIECE(MDRET(Y),U,2)?@("1"""_MDDATA_""".E")
Begin DoDot:1
+7 DO XMLHDR^MDCLIO("RECORD")
+8 DO XMLDATA^MDCLIO("ID",$PIECE(MDRET(Y),U,1))
+9 DO XMLDATA^MDCLIO("NAME",$PIECE(MDRET(Y),U,2))
+10 DO XMLFTR^MDCLIO("RECORD")
End DoDot:1
+11 KILL MDDATA
+12 DO ENDDOC^MDCLIO("RESULTS")
+13 QUIT
GETTIUPN ; Gets list of all Progress Note Titles
+1 NEW MDRET
KILL @RESULTS
+2 SET MDDATA=$$UP^XLFSTR(P2(0))
+3 DO NEWDOC^MDCLIO("RESULTS","VERSION INFORMATION")
+4 DO LONGLIST^TIUSRVD(.MDRET,3,MDDATA)
+5 IF $DATA(MDRET(44))
IF $PIECE($PIECE(MDRET(44),U,2),$$UP^XLFSTR(P2(0)))=""
DO XMLFTR^MDCLIO("RESULTS")
QUIT
+6 FOR Y=0:0
SET Y=$ORDER(MDRET(Y))
if 'Y
QUIT
if $PIECE(MDRET(Y),U,2)?@("1"""_MDDATA_""".E")
Begin DoDot:1
+7 DO XMLHDR^MDCLIO("RECORD")
+8 DO XMLDATA^MDCLIO("ID",$PIECE(MDRET(Y),U,1))
+9 DO XMLDATA^MDCLIO("NAME",$PIECE(MDRET(Y),U,2))
+10 DO XMLFTR^MDCLIO("RECORD")
End DoDot:1
+11 KILL MDDATA
+12 DO ENDDOC^MDCLIO("RESULTS")
+13 QUIT
GETUSER ; Gets the current users record in ^VA(200,
+1 SET MDROOT="MDROOT"
+2 SET MDROOT(DUZ)=""
+3 QUIT
GETLST ; Get a list of observations sent down in P2(0..n)=ID
+1 SET MDROOT=$NAME(^TMP("MDCLIO",$JOB))
KILL @MDROOT
+2 SET MDID=""
+3 FOR
SET MDID=$ORDER(P2(MDID))
if MDID=""
QUIT
if P2(MDID)]""
Begin DoDot:1
+4 SET X=$ORDER(^MDC(704.117,"PK",P2(MDID),0))
if X
SET @MDROOT@(0,X)=""
End DoDot:1
+5 QUIT
GETONE(ID) ; Get single Observation + Children if any
+1 SET X=$$FIND1^DIC(704.117,,"KXP",ID(0))
+2 if 'X
QUIT
SET @MDROOT@(0,X)=""
+3 FOR Y=0:0
SET Y=$ORDER(^MDC(704.117,"AP",X,Y))
if 'Y
QUIT
SET @MDROOT@(Y,$ORDER(^MDC(704.117,"AP",X,Y,0)))=""
+4 QUIT
LOCATION ; Get list of wards, clinics and non-stops
+1 NEW MDNOW
DO NOW^%DTC
SET MDNOW=%
+2 SET MDROOT=$NAME(^TMP("MDCLIO",$JOB))
KILL @MDROOT
+3 FOR X=0:0
SET X=$ORDER(^SC(X))
if 'X
QUIT
if "CWN"[$PIECE(^(X,0),U,3)
Begin DoDot:1
+4 ; No deactivation date on file
IF '+$GET(^SC(X,"I"))
SET @MDROOT@(X)=""
QUIT
+5 ; No reactivation date
IF +^SC(X,"I")<MDNOW&('$PIECE(^("I"),U,2))
QUIT
+6 ; future reactivation date
IF +^SC(X,"I")<MDNOW&($PIECE(^("I"),U,2)>MDNOW)
QUIT
+7 SET @MDROOT@(X)=""
End DoDot:1
+8 QUIT
+9 ;
GETSUPPG ; Get list of supplemental/optional pages for a date range
+1 ; P2(0)=Patient DFN
+2 ; P2(1)=Start Date
+3 ; P2(2)=Stop Date
+4 SET MDDFN=P2(0)
SET MDDT=P2(2)+.0000001
SET MDROOT=$NAME(^TMP("MDCLIO",$JOB))
KILL @MDROOT
+5 SET MDFR=$$FMDT^MDCLIO(P2(1))
+6 SET MDDT=$$FMDT^MDCLIO(P2(2))+.0000001
+7 FOR
SET MDDT=$ORDER(^MDC(704.1122,"ADT",MDDFN,MDDT),-1)
if 'MDDT
QUIT
Begin DoDot:1
+8 SET MDIEN=""
FOR
SET MDIEN=$ORDER(^MDC(704.1122,"ADT",MDDFN,MDDT,MDIEN),-1)
if 'MDIEN
QUIT
Begin DoDot:2
+9 ; Deactivated before start date
IF $GET(^MDC(704.1122,MDIEN,.2))
if $GET(^(.2))<MDFR
QUIT
+10 ; Deactivated Optional Page
IF +$GET(^MDC(704.1122,MDIEN,.2))&($PIECE($GET(^MDC(704.1122,MDIEN,.1)),U,4)=1)
QUIT
+11 SET @MDROOT@(MDIEN)=""
End DoDot:2
End DoDot:1
+12 QUIT
GETHL7(ID) ; Get text of HL7 Message from 704.002 entry
+1 SET IEN=+$$FIND1^DIC(704.002,,"KX",ID)
+2 DO XMLHDR^MDCLIO("HL7_TEXT")
+3 if IEN>0
Begin DoDot:1
+4 DO GETMSG^MDCPHL7B(.MDRET,IEN)
+5 SET X=MDRET
FOR
SET X=$QUERY(@X)
if $EXTRACT(X,1,$LENGTH(MDRET)-1)'=$EXTRACT(MDRET,1,$LENGTH(MDRET)-1)
QUIT
Begin DoDot:2
+6 DO XMLADD^MDCLIO($$XMLSAFE^MDCLIO(@X))
End DoDot:2
End DoDot:1
+7 DO XMLFTR^MDCLIO("HL7_TEXT")
+8 QUIT
SETACL ; Sets the ACL for an Item
+1 DO SETACL^MDCLIO
+2 QUIT
+3 ;
DELACL ; Removes and item from ACL
+1 DO DELACL^MDCLIO
+2 QUIT
+3 ;
SUBMIT ; Submits an HL7 message back to the queue
+1 NEW MDMSG,MDSTAT
+2 SET MDMSG=$$FIND1^DIC(704.002,,"KX",P2(0))
+3 IF MDMSG<1
SET @RESULTS@(0)="-1^NO SUCH MESSAGE"
QUIT
+4 ; Default to error if you didn't get a status
SET MDSTAT=$GET(P2(1),3)
+5 DO UPDATERP^MDCPHL7B(.MDRET,MDMSG,MDSTAT)
+6 SET @RESULTS@(0)="1^Submitted"
+7 QUIT
QRYDATE(MDRET,MDSTRT,MDSTOP) ; Get list of all observations by DATE/TIME
+1 KILL @MDRET
+2 FOR X=MDSTRT-.0000001:0
SET X=$ORDER(^MDC(704.117,"ADT",X))
if 'X!(X>MDSTOP)
QUIT
Begin DoDot:1
+3 FOR Y=0:0
SET Y=$ORDER(^MDC(704.117,"ADT",X,Y))
if 'Y
QUIT
Begin DoDot:2
+4 if $PIECE(^MDC(704.117,Y,0),U,9)'=1
QUIT
+5 SET @MDRET@($ORDER(@MDRET@(""),-1)+1)=$PIECE(^MDC(704.117,Y,0),U)
End DoDot:2
End DoDot:1
+6 SET @MDRET@(0)=+$ORDER(@MDRET@(""),-1)
+7 QUIT
QRYLST(MDRET,MDDFN,MDITEM,MDSTRT,MDSTOP) ; Get list of observations by VUID or TERM NAME
+1 NEW MDTERM
+2 KILL @MDRET
+3 ; Default today @00:00
SET MDSTRT=$GET(MDSTRT,DT\1)
+4 ; Default today @24:00
SET MDSTOP=$GET(MDSTOP,DT\1+.24)
+5 SET MDTERM=$$FIND1^DIC(704.101,"","PKMX",MDITEM,"C^VUID","I $P(^(0),U,5)=1")
+6 IF MDTERM<1
SET @MDRET@(0)="-1^Cannot find term '"_MDITEM_"'"
QUIT
+7 FOR X=MDSTRT-.0000001:0
SET X=$ORDER(^MDC(704.117,"PT",MDDFN,X))
if 'X!(X>MDSTOP)
QUIT
Begin DoDot:1
+8 FOR Y=0:0
SET Y=$ORDER(^MDC(704.117,"PT",MDDFN,X,Y))
if 'Y
QUIT
Begin DoDot:2
+9 if $PIECE(^MDC(704.117,Y,0),U,9)'=1
QUIT
+10 if $PIECE(^MDC(704.117,Y,0),U,7)'=MDTERM
QUIT
+11 SET @MDRET@($ORDER(@MDRET@(""),-1)+1)=$PIECE(^MDC(704.117,Y,0),U)
End DoDot:2
End DoDot:1
+12 SET @MDRET@(0)=+$ORDER(@MDRET@(""),-1)
+13 QUIT
+14 ;
QRYOBS(MDRET,MDID) ; Return a single observation
+1 NEW MDTMP
+2 KILL @MDRET
+3 SET MDIEN=$$FIND1^DIC(704.117,"","PKX",MDID,"PK")
+4 IF MDIEN<1
SET @MDRET@(0)="-1^No such observation '"_MDID_"'"
QUIT
+5 DO GETS^DIQ(704.117,MDIEN_",","*","EIR","MDTMP")
+6 MERGE @MDRET=MDTMP(704.117,MDIEN_",")
KILL MDTMP
+7 SET @MDRET@("TERM_ID","I")=$$GET1^DIQ(704.117,MDIEN_",",".07:99.99")
+8 SET @MDRET@("TERM_ID","E")=$$GET1^DIQ(704.117,MDIEN_",",".07:.02")
+9 ; Coded data values
if $$GET1^DIQ(704.117,MDIEN_",",".07
Begin DoDot:1
+10 SET MDTMP=$$FIND1^DIC(704.101,"","PKX",@MDRET@("SVALUE","I"),"PK")
+11 SET @MDRET@("SVALUE","E")=$$GET1^DIQ(704.101,MDTMP_",",.02)
End DoDot:1
+12 DO QRYQUAL(MDRET,MDIEN)
+13 DO QRYCTX($NAME(@MDRET@("CONTEXT")),MDID)
+14 QUIT
+15 ;
QRYQUAL(MDRET,MDIEN) ; Returns the qualifiers for obs in MDIEN
+1 NEW MDQUAL
+2 FOR Y=0:0
SET Y=$ORDER(^MDC(704.118,"PK",MDIEN,Y))
if 'Y
QUIT
Begin DoDot:1
+3 SET MDQUAL=$$GET1^DIQ(704.101,Y_",",".05:.02")
+4 SET @MDRET@(MDQUAL,"I")=$$GET1^DIQ(704.101,Y_",","99.99")
+5 SET @MDRET@(MDQUAL,"E")=$$GET1^DIQ(704.101,Y_",",".02")
End DoDot:1
+6 QUIT
+7 ;
QRYCTX(MDRET,MDID) ; We need a terminology based context observation relationship here
+1 NEW MDIEN,MDCTX,MDDT,MDFROM,MDTO,MDDFN,MDTERM,MDCNT,MDXID
+2 SET MDIEN=+$$FIND1^DIC(704.117,"","PKX",MDID,"PK")
if MDIEN<1
QUIT
+3 ; GET THE PRIMARY TERM (GUID)
SET MDCTX=$$GET1^DIQ(704.117,MDIEN_",",.07)
+4 ; FILTER OUT EVERYTHING BUT SpO2 for now
+5 if MDCTX'="{5F84DD55-3CCF-094C-2536-B51EB7FAD999}"
QUIT
+6 ; GET THE PATIENT
SET MDDFN=+$$GET1^DIQ(704.117,MDIEN_",",.08,"I")
+7 ; GET THE OBS DATE
SET MDDT=+$$GET1^DIQ(704.117,MDIEN_",",.05,"I")
+8 ; PREVIOUS 30 SECONDS
SET MDFROM=$$FMADD^XLFDT(MDDT,0,0,0,-30)
+9 ; NEXT 30 SECONDS
SET MDTO=$$FMADD^XLFDT(MDDT,0,0,0,30)
+10 ; Now we find the context observations
+11 FOR MDDT=MDFROM:0
SET MDDT=$ORDER(^MDC(704.117,"PT",MDDFN,MDDT))
if 'MDDT!(MDDT>MDTO)
QUIT
Begin DoDot:1
+12 FOR MDOBS=0:0
SET MDOBS=$ORDER(^MDC(704.117,"PT",MDDFN,MDDT,MDOBS))
if 'MDOBS
QUIT
Begin DoDot:2
+13 ; Verfied Only
if $$GET1^DIQ(704.117,MDOBS_",",.09,"I")'=1
QUIT
+14 SET MDXID=$$GET1^DIQ(704.117,MDOBS_",",.01)
+15 ; You should ignore yourself in this loop
if MDXID=MDID
QUIT
+16 SET MDTERM=$$GET1^DIQ(704.117,MDOBS_",",".07")
+17 ; INSERT FILTER CODE FOR O2 Flowrate and Concentration here - In the future we will find all context terms for an observation in terminology
+18 if (MDTERM'="{56F82CAC-3564-46CE-A520-1025020DADE9}")&(MDTERM'="{3BB314E8-9BBB-480E-B34E-B56EDE43BAC4}")
QUIT
+19 SET MDCNT=$ORDER(@MDRET@(""),-1)+1
SET @MDRET@(0)=MDCNT
+20 SET @MDRET@(MDCNT,"OBS_ID","I")=MDXID
+21 SET @MDRET@(MDCNT,"OBS_ID","E")=MDXID
+22 SET @MDRET@(MDCNT,"TERM_ID","I")=$$GET1^DIQ(704.117,MDOBS_",",".07:99.99")
+23 SET @MDRET@(MDCNT,"TERM_ID","E")=$$GET1^DIQ(704.117,MDOBS_",",".07:.02")
+24 SET @MDRET@(MDCNT,"SVALUE","I")=$$GET1^DIQ(704.117,MDOBS_",",".1","I")
+25 SET @MDRET@(MDCNT,"SVALUE","E")=$$GET1^DIQ(704.117,MDOBS_",",".1","E")
+26 DO QRYQUAL($NAME(@MDRET@(MDCNT)),MDOBS)
End DoDot:2
End DoDot:1
+27 QUIT
GETOBS(MDPAR) ; Get list of observations by date
+1 SET MDPT=MDPAR(0)
+2 SET MDROOT=$NAME(^TMP("MDCLIO",$JOB))
KILL @MDROOT
+3 SET MDFR=$$FMDT^MDCLIO(MDPAR(1))-.0000001
+4 SET MDTO=$$FMDT^MDCLIO(MDPAR(2))\1+.235959
+5 FOR
SET MDFR=$ORDER(^MDC(704.117,"PT",MDPT,MDFR))
if 'MDFR!(MDFR>MDTO)
QUIT
Begin DoDot:1
+6 FOR Y=0:0
SET Y=$ORDER(^MDC(704.117,"PT",MDPT,MDFR,Y))
if 'Y
QUIT
SET @MDROOT@(Y)=""
End DoDot:1
+7 QUIT
GETBYDT ; Get list of observations by date
+1 SET MDPT=P2(0)
+2 SET MDROOT=$NAME(^TMP("MDCLIO",$JOB))
KILL @MDROOT
+3 SET MDFR=$$FMDT^MDCLIO(P2(1))-.0000001
+4 SET MDTO=$$FMDT^MDCLIO(P2(2))
+5 FOR
SET MDFR=$ORDER(^MDC(704.117,"PT",MDPT,MDFR))
if 'MDFR!(MDFR>MDTO)
QUIT
Begin DoDot:1
+6 FOR Y=0:0
SET Y=$ORDER(^MDC(704.117,"PT",MDPT,MDFR,Y))
if 'Y
QUIT
SET @MDROOT@(Y)=""
End DoDot:1
+7 QUIT
GETLOG ; Get list of date/time pairs with data
+1 SET MDPT=P2(0)
SET MDROOT=$NAME(^TMP("MDCLIO",$JOB))
KILL @MDROOT
+2 SET MDFR=$$FMDT^MDCLIO(P2(1))-.0000001
+3 SET MDTO=$$FMDT^MDCLIO(P2(2))
+4 SET MDSTAT=""
+5 FOR
SET MDSTAT=$ORDER(^MDC(704.117,"AS",MDSTAT))
if MDSTAT=""
QUIT
Begin DoDot:1
+6 SET MDDT=MDFR
+7 FOR
SET MDDT=$ORDER(^MDC(704.117,"AS",MDSTAT,MDPT,MDDT))
if 'MDDT!(MDDT>MDTO)
QUIT
Begin DoDot:2
+8 SET @MDROOT@(MDSTAT,MDDT,$ORDER(^MDC(704.117,"AS",MDSTAT,MDPT,MDDT,0)))=""
End DoDot:2
End DoDot:1
+9 QUIT
GETBYST ; Get list of observations by patient, status, and date range
+1 SET MDPT=P2(0)
SET MDSTAT=P2(3)
SET MDROOT=$NAME(^TMP("MDCLIO",$JOB))
KILL @MDROOT
+2 SET MDFR=$$FMDT^MDCLIO(P2(1))-.0000001
+3 SET MDTO=$$FMDT^MDCLIO(P2(2))
+4 FOR
SET MDFR=$ORDER(^MDC(704.117,"AS",MDSTAT,MDPT,MDFR))
if 'MDFR!(MDFR>MDTO)
QUIT
Begin DoDot:1
+5 FOR Y=0:0
SET Y=$ORDER(^MDC(704.117,"AS",MDSTAT,MDPT,MDFR,Y))
if 'Y
QUIT
SET @MDROOT@(Y)=""
End DoDot:1
+6 QUIT
AUDIT(Y) ; Looks up the audit records for an observation in external format
+1 SET MDROOT=$NAME(^MDC(704.119,"ALOG",+$ORDER(^MDC(704.117,"PK",Y,0))))
+2 QUIT
QUAL ; Retrieves all qualifiers for an observation - MDIENS = iens of observation from MDCLIO
+1 NEW MDQUAL
+2 FOR MDQUAL=0:0
SET MDQUAL=$ORDER(^MDC(704.118,"PK",+MDIENS,MDQUAL))
if 'MDQUAL
QUIT
Begin DoDot:1
+3 DO XMLDATA^MDCLIO($$GET1^DIQ(704.101,MDQUAL_",",".05:.02","I"),$$GET1^DIQ(704.101,MDQUAL_",",".01","I"))
End DoDot:1
+4 QUIT
SETS ; Retrieve the sets this observation belongs to
+1 DO XMLHDR^MDCLIO("SETS")
+2 NEW MDSET
FOR MDSET=0:0
SET MDSET=$ORDER(^MDC(704.1161,"AS",+MDIENS,MDSET))
if 'MDSET
QUIT
Begin DoDot:1
+3 FOR MDX=0:0
SET MDX=$ORDER(^MDC(704.1161,"AS",+MDIENS,MDSET,MDX))
if 'MDX
QUIT
Begin DoDot:2
+4 DO XMLHDR^MDCLIO("SET")
+5 DO XMLDATA^MDCLIO("VALUE",$$GET1^DIQ(704.1161,MDX_",",.01))
+6 DO XMLFTR^MDCLIO("SET")
End DoDot:2
End DoDot:1
+7 DO XMLFTR^MDCLIO("SETS")
+8 QUIT
GETQUAL ; Returns qualifiers of type P2(1) for term P2(0)
+1 ; Set Y to the IEN of the Term
+2 SET X=$$FIND1^DIC(704.101,"","KX",P2(0))
+3 SET MDROOT=$NAME(^TMP("MDCLIO",$JOB))
KILL @MDROOT
+4 SET MDGBL=$NAME(^MDC(704.103,"PK",X))
+5 FOR
SET MDGBL=$QUERY(@MDGBL)
if MDGBL=""
QUIT
if $QSUBSCRIPT(MDGBL,3)'=X
QUIT
Begin DoDot:1
+6 IF $PIECE(^MDC(704.101,$QSUBSCRIPT(MDGBL,5),0),U,5)=P2(1)
Begin DoDot:2
+7 SET @MDROOT@($QSUBSCRIPT(MDGBL,4),$QSUBSCRIPT(MDGBL,6))=""
End DoDot:2
End DoDot:1
+8 QUIT
PROCIEN(Y) ; Converts CP DEFINITION (procedure) name to IEN
+1 QUIT $$FIND1^DIC(702.01,,"KXP",Y)
INSTIEN(Y) ; Converts CP INSTRUMENT name to IEN
+1 QUIT $$FIND1^DIC(702.09,,"KXP",Y)
GETINST ; Gathers instruments for a procedure
+1 SET X=$$PROCIEN(P2(0))
+2 FOR Y=0:0
SET Y=$ORDER(^MDS(702.01,+X,.1,"B",Y))
if 'Y
QUIT
SET @MDROOT@(Y)=""
+3 QUIT
ADDINST ; Adds an instrument definition to a procedure
+1 ; This is a legacy multiple in file 702.01 so it has to be done in an odd way
+2 NEW MDPROC,MDINST
+3 SET MDPROC=$$PROCIEN(P2(0))
+4 SET MDINST=$$INSTIEN(P2(1))
+5 IF '+MDPROC
SET @RESULTS@(0)="-1^Unable to find procedure "_P2(0)
+6 IF '+MDINST
SET @RESULTS@(0)="-1^Unable to find instrument "_P2(1)
+7 SET MDFDA(702.011,"+1,"_MDPROC_",",.01)=MDINST
+8 DO UPDATE^DIE("","MDFDA")
+9 SET @RESULTS@(0)="1^Instrument added."
+10 QUIT
DELINST ; Deletes all instruments from a procedure definition
+1 ; This is a legacy multiple in file 702.01 so it has to be done in an odd way
+2 NEW MDPROC
+3 SET MDPROC=$$PROCIEN(P2(0))
+4 FOR X=0:0
SET X=$ORDER(^MDS(702.01,MDPROC,.1,X))
if 'X
QUIT
SET MDFDA(702.011,X_","_MDPROC_",",.01)="@"
+5 DO FILE^DIE("","MDFDA")
+6 SET @RESULTS@(0)="1^Instrument list cleared."
+7 QUIT
GETVER ; Get Version Information
+1 DO NEWDOC^MDCLIO("RESULTS","VERSION INFORMATION")
+2 IF $GET(P2(0))=""
DO GETLST^XPAR(.MDRET,"SYS","MD VERSION INFORMATION","Q")
+3 IF $GET(P2(0))]""
SET MDRET(1)=P2(0)_"^"_$$GET^XPAR("SYS","MD VERSION INFORMATION",P2(0),"Q")
+4 ; Switch the lines below once we are really checking versions
+5 ;F MDRET=0:0 S MDRET=$O(MDRET(MDRET)) Q:'MDRET D:$P(MDRET(MDRET),"^",2)]""
+6 FOR MDRET=0:0
SET MDRET=$ORDER(MDRET(MDRET))
if 'MDRET
QUIT
Begin DoDot:1
+7 DO XMLHDR^MDCLIO("RECORD")
+8 SET MDVER=$PIECE(MDRET(MDRET),"^",1)
+9 DO XMLDATA^MDCLIO("VERSION",MDVER)
+10 SET MDVER=$PIECE(MDRET(MDRET),"^",2)
+11 ; Switch the lines below once we are really checking versions
+12 ;D XMLDATA^MDCLIO("COMPATIBLE",+MDVER)
+13 DO XMLDATA^MDCLIO("COMPATIBLE",1)
+14 DO XMLDATA^MDCLIO("CRC32",$PIECE(MDVER,";",2))
+15 DO XMLDATA^MDCLIO("PRODUCTION_RELEASE",+$PIECE(MDVER,";",3))
+16 DO XMLDATA^MDCLIO("COMMENT",$PIECE(MDVER,";",4))
+17 DO XMLFTR^MDCLIO("RECORD")
End DoDot:1
+18 DO ENDDOC^MDCLIO("RESULTS")
+19 QUIT
GETVF ; Get View Filters
+1 NEW MDVIEW,MDTERM,MDIEN,MDXROOT
+2 SET MDXROOT=$NAME(^TMP("MDXQUERY",$JOB))
KILL @MDXROOT
+3 SET MDVIEW=+$ORDER(^MDC(704.111,"PK",P2(0),0))
+4 FOR MDTERM=0:0
SET MDTERM=$ORDER(^MDC(704.1112,"PK",MDVIEW,P2(1),MDTERM))
if 'MDTERM
QUIT
Begin DoDot:1
+5 FOR MDIEN=0:0
SET MDIEN=$ORDER(^MDC(704.1112,"PK",MDVIEW,P2(1),MDTERM,MDIEN))
if 'MDIEN
QUIT
SET @MDXROOT@(MDIEN)=MDIEN
End DoDot:1
+6 DO XQUERY^MDCLIO
+7 QUIT
NEWNOTE ; Returns a new note ID
+1 DO GETGUID(.MD)
+2 KILL ^TMP("MDNOTE",$JOB,MD)
+3 DO QUICKDOC^MDCLIO("ID",MD)
+4 QUIT
CLRNOTE ; Clears any text in a temporary note P2(0)=Temporary ID
+1 KILL ^TMP("MDNOTE",$JOB,P2(0))
+2 SET @RESULTS@(0)="1^Note Cleared"
+3 QUIT
ADDTEXT ; Adds P2(1..n) to the note in P2(0)
+1 FOR X=0:0
SET X=$ORDER(P2(X))
if 'X
QUIT
Begin DoDot:1
+2 SET Y=$ORDER(^TMP("MDNOTE",$JOB,P2(0),""),-1)+1
+3 SET ^TMP("MDNOTE",$JOB,P2(0),Y,0)=P2(X)
End DoDot:1
+4 SET @RESULTS@(0)=$ORDER(P2(""),-1)_"^Lines added"
+5 QUIT
+6 ;
SENDMAIL ; Sends an EMail Message
+1 DO SENDMAIL^MDCLIO
+2 ;
GETTIU ; Gets Privs for note title in P2(0)
+1 NEW MDRET
+2 DO NEWDOC^MDCLIO("RESULTS","TIU PRIVS")
+3 DO XMLHDR^MDCLIO("RECORD")
+4 DO REQCOS^TIUSRVA(.MDRET,P2(0))
+5 DO XMLDATA^MDCLIO("REQUIRE_COSIGN",MDRET)
+6 DO GETDCOS^ORWTPN(.MDRET,DUZ)
+7 if +MDRET
Begin DoDot:1
+8 DO XMLDATA^MDCLIO("DEF_COSIGN_ID",$PIECE(MDRET,U,1))
+9 DO XMLDATA^MDCLIO("DEF_COSIGN_NAME",$PIECE(MDRET,U,2))
End DoDot:1
+10 DO XMLFTR^MDCLIO("RECORD")
+11 DO ENDDOC^MDCLIO()
+12 QUIT
+13 ;
SIGNTIU ; Signs the note
+1 NEW MDNOW,MDESIG,MDNOTE,MDTEXT,MDVAU,MDRET
+2 DO NOW^%DTC
SET MDNOW=%
+3 SET MDESIG=$$DECRYP^XUSRB1(P2(4))
SET MDESIG=$$ENCRYP^XUSRB1(MDESIG)
+4 DO MAKE^TIUSRVP(.MDNOTE,P2(1),P2(2),MDNOW,P2(3))
+5 IF MDNOTE<1
SET @RESULTS@(0)="-1^Unable to create note."
QUIT
+6 SET MDTEXT(2)=$NAME(^TMP("MDNOTE",$JOB,P2(0)))
+7 ; Check for a co-signer
+8 IF +$GET(P2(5))
SET MDTEXT(1506)=1
SET MDTEXT(1208)=+$GET(P2(5))
+9 DO UPDATE^TIUSRVP(.MDRET,+MDNOTE,.MDTEXT,1)
+10 IF MDRET<1
SET @RESULTS@(0)="-1^Unable to file note text."
QUIT
+11 DO SIGN^TIUSRVP(.MDRET,MDNOTE,MDESIG)
+12 KILL MDESIG
+13 IF MDRET<0
SET @RESULTS@(0)="-1^Unable to sign the note."
QUIT
+14 SET @RESULTS@(0)="1^Note signed and filed."
+15 QUIT
+16 ;
GETENT(X) ; Returns the entity path upward
+1 QUIT X_$PIECE("USR^DIV^SYS",X,2)
+2 ;
OPENPAR ; Opens and verifies a parameter Entity
+1 DO NOW^%DTC
SET %=%+.00000001
+2 SET Y=($EXTRACT(%,1,3)+1700)_"-"_$EXTRACT(%,4,5)_"-"_$EXTRACT(%,6,7)_" "_$EXTRACT(%,9,10)_":"_$EXTRACT(%,11,12)_":"_$EXTRACT(%,13,14)
+3 DO EN^XPAR("USR",P2(0),"Date/Time Last Accessed",Y,.MDERR)
+4 IF 'MDERR
SET @RESULTS@(0)="1"
IF '$TEST
SET @RESULTS@(0)=MDERR
+5 QUIT
LSTPAR ; Returns all parameter Values as a Query
+1 ; GETLST^XPAR(.List,Entity,Parameter,Format,.Error)
+2 NEW MDLST,MDENT,MDNAME
+3 DO NEWDOC^MDCLIO("RESULTS")
+4 DO GETLST^XPAR(.MDRET,P2(0),P2(1),"Q",.MDERR)
+5 FOR Y=0:0
SET Y=$ORDER(MDRET(Y))
if 'Y
QUIT
SET MDLST($PIECE(MDRET(Y),U,1))=$PIECE(MDRET(Y),U,2,250)
+6 KILL MDRET
+7 if 'MDERR
Begin DoDot:1
+8 SET MDNAME=""
FOR
SET MDNAME=$ORDER(MDLST(MDNAME))
if MDNAME=""
QUIT
Begin DoDot:2
+9 DO XMLHDR^MDCLIO("RECORD")
+10 DO XMLDATA^MDCLIO("NAME",MDNAME)
+11 DO XMLDATA^MDCLIO("VALUE",MDLST(MDNAME))
+12 DO XMLFTR^MDCLIO("RECORD")
End DoDot:2
End DoDot:1
+13 DO ENDDOC^MDCLIO("RESULTS")
+14 QUIT
CLRPAR ; Clears all settings for an entity
+1 DO NDEL^XPAR(P2(0),P2(1),.MDERR)
+2 IF 'MDERR
SET @RESULTS@(0)=1
IF '$TEST
SET @RESULTS@(0)=MDERR
+3 QUIT
SETPAR ; Sets a single parameter value
+1 NEW MDVALUE
+2 SET MDVALUE=$GET(P2(3),"@")
if MDVALUE=""
SET MDVALUE="@"
+3 DO STRIP^MDCLIO(MDVALUE)
+4 IF MDVALUE="@"
Begin DoDot:1
+5 DO DEL^XPAR(P2(0),P2(1),P2(2),.MDERR)
+6 SET @RESULTS@(0)=1
End DoDot:1
QUIT
+7 DO EN^XPAR(P2(0),P2(1),P2(2),MDVALUE,.MDERR)
+8 SET @RESULTS@(0)='MDERR
+9 QUIT
GETPAR ; Gets a single parameter value
+1 NEW MDVALUE
+2 DO NEWDOC^MDCLIO("RESULTS")
+3 DO XMLHDR^MDCLIO("RECORD")
+4 SET MDVALUE=$$GET^XPAR(P2(0),P2(1),P2(2),"Q")
+5 if MDVALUE]""
DO XMLDATA^MDCLIO("VALUE",MDVALUE)
+6 DO XMLFTR^MDCLIO("RECORD")
+7 DO ENDDOC^MDCLIO("RESULTS")
+8 QUIT
