ORMSD ; SLC/AGP - Process Scheduling ORM msgs ;04/05/18
;;3.0;ORDER ENTRY/RESULTS REPORTING;**434,475,483**;Dec 17, 1997;Build 45
;
;EN builds an results array
;INPUTS("APPT IEN")=0
;INPUTS("APPT TYPE")="followup"
;INPUTS("CLINIC")="240^20 MINUTE"
;INPUTS("COMMENT")="This is the new comment field"
;INPUTS("ENTERED BY")="10000000195^PULEO,ANTHONY"
;INPUTS("INTERVAL")="Q7D"
;INPUTS("MSG ID")=""
;INPUTS("DISCONTINUE")=1
;INPUTS("ENTERED IN ERROR")=1
;INPUTS("NLT")=1
;INPUTS("NUMBER APPT")=4
;INPUTS("ORDER IEN")=14524362
;INPUTS("PATIENT")="346^"
;INPUTS("PREREQ",2)="XRAY"
;INPUTS("PREREQ",3)="VITALS"
;INPUTS("RTC DATE")=20170524
;INPUTS("SIGNED BY")=""
;
;
UNESC(STR) ;
Q $$UNESC^ORHLESC(STR)
;
CREATACT(NATURE) ;
N IEN
S IEN=$O(^ORD(100.02,"C",NATURE,"")) I IEN'>0 Q 0
I +$P($G(^ORD(100.02,IEN,1)),U)=1 Q 1
Q 0
;
EN(MSG) ; -- main entry point for OR RECEIVE where MSG contains HL7 msg
N ACTION,AIG,AIL,ARQ,DATE,ENTER,ERROR,FAILMSA,FREQ,HASMSA,INST,MSH,NODE,NUM,NXT,ORMSG,PAT,RESULT,X,PID,PV1,SEG,SIGN
S ERROR=""
S ORMSG=$S($L($G(MSG)):MSG,1:"MSG") ; MSG="NAME" or MSG(#)=message
I '$O(@ORMSG@(0)) D EN^ORERR("Missing HL7 message",.MSG) Q
S MSH=0 F S MSH=$O(@ORMSG@(MSH)) Q:MSH'>0 Q:$E(@ORMSG@(MSH),1,3)="MSH"
I 'MSH D EN^ORERR("Missing or invalid MSH segment",.MSG)
S X=0,FAILMSA=0,HASMSA=0 F S X=$O(@ORMSG@(X)) Q:X'>0!(ERROR'="")!(HASMSA=1) D
.S SEG=$P(@ORMSG@(X),"|"),NODE=$P(@ORMSG@(X),"|",2,99)
.I SEG="MSA" S HASMSA=1
.S SEG=SEG_"(.RESULT,X,NODE,.ERROR)"
.D @SEG
I FAILMSA=1 D REJECT(.RESULT) G ENX
I HASMSA=1 D ACCEPT(.RESULT) G ENX
I $G(ERROR)'="" D SENDFAIL(.ERROR,.RESULT) G ENX
I '$$VALIDATE(.RESULT,.ERROR) D SENDFAIL(.ERROR,.RESULT) G ENX
D SAVEREC(.RESULT)
D SENDOK(.RESULT)
ENX ;
Q
;
LASTACT(ORIFN) ;
N RESULT
I ORIFN[";" S RESULT=$P(ORIFN,";",2) G LASTACTX
S RESULT=$O(^OR(100,ORIFN,8,""),-1)
I RESULT="" S RESULT=1
LASTACTX ;
Q RESULT
;
MSH(RESULT,X,SEG,ERROR) ;
S RESULT("MSG ID")=$P(SEG,"|",9)
S RESULT("MSG DATE/TIME")=$$HL7TFM^XLFDT($P(SEG,"|",6),"L")
Q
;
MSA(RESULT,X,SEG,ERROR) ;
N STATUS
I $P(SEG,"|")'="AR" D Q
.S STATUS=$P(SEG,"|",2)
.S RESULT("APPT IEN")=$P(STATUS,U,2)
S RESULT("REJECTION ERROR")=$P(SEG,"|",2) S FAILMSA=1
;S OREASON=RESULT("REJECTION ERROR")
Q
;
SCH(RESULT,X,SEG,ERROR) ;
N TIME
S RESULT("ORDER IEN")=$P(SEG,"|",2),RESULT("APPT IEN")=+$P(SEG,"|",1)
S RESULT("APPT TYPE")=$P($P(SEG,"|",5),U,2)
S ACTION=$P(SEG,"|",6) S RESULT($S($P(ACTION,U)="S15":"DISCONTINUE",1:"COMPLETE"))=1
I $P(ACTION,U,2)="PARTIAL" S RESULT("PARTIAL")=1
S DATE=$P(SEG,"|",8),TIME=$P(SEG,"|",9)
I TIME="T" S RESULT("NLT")=1
S RESULT("RTC DATE")=$$HL7TFM^XLFDT($S(TIME="T":$P(DATE,U,2),1:$P(DATE,U)),"L")
S FREQ=$P(SEG,"|",10),NUM=+$P(SEG,"|",11)
S RESULT("NUMBER APPT")=NUM I NUM>0 S RESULT("INTERVAL")=+$E(FREQ,2,3)
S RESULT("SIGNED BY")=$P(SEG,"|",14)
S RESULT("DISPOSITION BY")=$P(SEG,"|",16)
Q
;
AIL(RESULT,X,SEG,ERROR) ;
S RESULT("CLINIC")=$P(SEG,"|",3)
Q
AIG(RESULT,X,SEG,ERROR) ;
N INST,NODE
S RESULT("PREREQ",$P(SEG,"|"))=$P($P(SEG,"|",2),U,2)
S INST=0 F S INST=$O(@ORMSG@(X,INST)) Q:INST'>0 D
.S NODE=$P(@ORMSG@(X,INST),"|",2,99)
.S RESULT("PREREQ",$P(NODE,"|"))=$P($P(NODE,"|",2),U,2)
Q
;
NTE(RESULT,X,SEG,ERROR) ;
S RESULT("COMMENT")=$$UNESC($P(SEG,"|",3))
Q
;
;
PID(RESULT,X,SEG,ERROR) ;
S RESULT("PATIENT")=$P(SEG,"|",3)_U_$P(SEG,"|",5)
Q
;
PV1(RESULT,X,SEG,ERROR) ; -- Gets Patient location info.
; may not be needed for scheduling
Q
;
FMDATE(Y) ; -- Convert HL7 date/time to FM format
Q $$HL7TFM^XLFDT(Y)
;
REJECT(RESULT) ;
N ORIFN,ORNATR
S ORIFN=$P($G(RESULT("MSG ID")),U) Q:+ORIFN'>0
S:'$G(ORNATR) ORNATR="X" ;Rejected
S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_U_+$E($$NOW^XLFDT,1,12)_U_U_RESULT("REJECTION ERROR")
I $P($G(^OR(100,+ORIFN,3)),U,11)=2 N ORIG S ORIG=$P(^(3),U,5) S:ORIG $P(^OR(100,ORIG,3),U,6)="" ;remove fwd ptr if pending renewal
S ORERR=RESULT("REJECTION ERROR")
N ORDA S ORDA=+$P(ORIFN,";",2) I ORDA D
. S $P(^OR(100,+ORIFN,8,ORDA,0),U,15)=13 ;request rejected
. S:$L(RESULT("REJECTION ERROR")) ^OR(100,+ORIFN,8,ORDA,1)=RESULT("REJECTION ERROR")
D STATUS^ORCSAVE2(+ORIFN,13)
Q
;
ACCEPT(RESULT) ;
N ORIFN
S ORIFN=$P($G(RESULT("MSG ID")),U)
I $P(RESULT("MSG ID"),U,2)'="S05" D Q
.S ^OR(100,+ORIFN,4)=$G(RESULT("APPT IEN"))
.D STATUS^ORCSAVE2(+ORIFN,5)
.D DATES^ORCSAVE2(+ORIFN,DT,"")
D DCACK(+ORIFN,.RESULT)
Q
;
DCACK(ORIFN,RESULT) ;
N ORSTS
;set status to discontinue used as a variable for future code changes
S ORSTS=1
D EXPDT(ORIFN)
D STATUS^ORCSAVE2(+ORIFN,ORSTS)
I $G(RESULT("APPT IEN"))'="" S ^OR(100,+ORIFN,4)=RESULT("APPT IEN")
Q
;
GETSTAT(RESULT) ;
I +$G(RESULT("DISCONTINUE")) Q $O(^ORD(100.01,"B","DISCONTINUED",""))
I +$G(RESULT("PARTIAL")) Q $O(^ORD(100.01,"B","PARTIAL RESULTS",""))
Q $O(^ORD(100.01,"B","COMPLETE",""))
;
EXPDT(ORIFN) ; -- save exp date when dc'd
N STOP S STOP=$P($G(^OR(100,+ORIFN,0)),U,9)
I STOP,STOP<$$NOW^XLFDT,'$P($G(^OR(100,+ORIFN,6)),U,6) S $P(^(6),U,6)=STOP
Q
;
VALIDATE(RESULT,ERROR) ;
N OK,ORIFN,OR3,STS
S OK=1
I +$G(RESULT("CLINIC"))'>0 S ERROR="Clinic location not defined" S OK=0 G VALIDATX
I '$G(RESULT("COMPLETE")),'$G(RESULT("DISCONTINUE")) S ERROR="Status not defined" S OK=0 G VALIDATX
I +$G(RESULT("PATIENT"))'>0 S ERROR="Patient is not defined" S OK=0 G VALIDATX
I +$G(RESULT("PATIENT"))_";DPT("'=$P($G(^OR(100,RESULT("ORDER IEN"),0)),U,2) S ERROR="Patient doesn't match" S OK=0 G VALIDATX
I '+$G(RESULT("DISPOSITION BY")) S ERROR="User who disposition the order not defined" S OK=0 G VALIDATX
S ORIFN=RESULT("ORDER IEN") I +ORIFN'>0 S ERROR="Order number not defined" S OK=0 G VALIDATX
S OR3=$G(^OR(100,+ORIFN,3)),STS=$P(OR3,U,3)
I STS=1!(STS=2) S ERROR="Order with a status of "_$S(STS=1:"discontinued",1:"complete")_" cannot be changed" S OK=0 G VALIDATX
VALIDATX ;
Q OK
;
SAVEREC(RESULT) ;
N C,CREATACT,DISPBY,I,ID,ISTIME,OERR,ORDA,ORDG,ORDIALOG,ORIFN,ORNATR,ORNP,ORNOW,ORPKG,ORSTRT,ORVP,ORWHO,STATUS,TYPE,WHOSIGN,X0,X8
N ORLEAD,ORTRAIL
S ORWHO=+RESULT("DISPOSITION BY")
S ORNP=ORWHO
S ORNOW=+$E($$NOW^XLFDT,1,12)
S ORDIALOG=+$O(^ORD(101.41,"AB","SD RTC",0))
S ORDG=+$O(^ORD(100.98,"B","CLINIC SCHEDULING",0))
S ORIFN=RESULT("ORDER IEN")
S ORVP=+RESULT("PATIENT")_";DPT("
S ORPKG=+$$PKG("SD") D GETDLG1^ORCD(ORDIALOG),GETORDER^ORCD(+ORIFN,"ORDIALOG")
;set ORDIALOG array to values returned from scheduling single instance
S ORDA=$P(ORIFN,";",2) I ORDA="" S ORDA=1
S X0=$G(^OR(100,+ORIFN,0)),X8=$G(^OR(100,ORIFN,8,ORDA,0))
;get whosigned and start date for later
S WHOSIGN=$P(X8,U,5),ORSTRT=$P(X0,U,8)
;update package reference
S ^OR(100,+ORIFN,4)=$G(RESULT("APPT IEN"))
;create new order action
;set to complete status until next iteration of VSE
S STATUS=$$GETSTAT(.RESULT)
S TYPE=$S(+$G(RESULT("DISCONTINUE")):"DC",1:"XX")
D STATUS^ORCSAVE2(ORIFN,STATUS)
S CREATACT=$$CREATACT("I")
I CREATACT=1 S ORDA=$$ACTION^ORCSAVE(TYPE,ORIFN,WHOSIGN,$S(TYPE="DC":"Per Scheduling",1:""),ORNOW,ORWHO)
I CREATACT=0 S ORDA=$$LASTACT(ORIFN)
;if order is not created how to get this to expert system
I ORDA'>0 S ORERR="Cannot create new order action" Q
;update status to compete set indexes
;I TYPE'="DC" D SETALL^ORDD100(ORIFN)
D SETALL^ORDD100(ORIFN)
;set the order as it has been release to scheduling with the update
D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,ORWHO,"I")
S ORNATR="I"
D SIGSTS^ORCSAVE2(+ORIFN,ORDA)
;update dates
D DATES^ORCSAVE2(ORIFN,ORSTRT,ORNOW)
;set disposition fields
N DA,DR,DIE
S DA(1)=ORIFN,DA=ORDA
S DIE="^OR(100,"_DA(1)_",8,"
S DR="40////"_ORWHO_";41////"_RESULT("MSG DATE/TIME")
D ^DIE
S $P(^OR(100,+ORIFN,8,ORDA,0),U,14)=ORDA
S $P(^OR(100,+ORIFN,3),U,7)=ORDA
I TYPE="DC" D
.D CANCEL^ORCSEND(+ORIFN)
.D EN^ORB3(91,+RESULT("PATIENT"),ORIFN,"","Appointment Request Cancelled in Scheduling","NEW,"_ORIFN) Q
S ISTIME=+$G(ORDIALOG($$PTR("YES/NO"),1))
S ORLEAD=$S(ISTIME=1:"no later than ",1:"on or around ("),ORTRAIL=$S(ISTIME=1:"",1:")")
K ^OR(100,+ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(+ORIFN_";"_ORDA)
;update the dialog and package fiels. This may have value in future version of VSE
S $P(^OR(100,ORIFN,0),U,5)=ORDIALOG_";ORD(101.41,",$P(^(0),U,14)=ORPKG
;validate display group and update if needed
I $P(^OR(100,ORIFN,0),U,11)'=ORDG D
. N DA,DR,DIE
. S DA=ORIFN,DR="23////"_ORDG,DIE="^OR(100," D ^DIE
;S $P(^(8,ORDA,0),U,14)=ORDA
;send back ack back, because scheduling is using a SRM message this code is branched from
;the standard OR HL7 message. This handle in the EN line tag of this routine.
;S ORIFN=ORIFN_";"_ORDA,ORDCNTRL="SN" ;to send NA msg back
Q
;
UPDRESP(ORIFN,ORDIALOG) ;
N C,I,ID,TYPE
F ID="LOCATION","CLINICALLY","YN","SDNUM","SDINT","SDCOMMENT" D
.S TYPE=$$PMPTMAP(ID) I ID="" Q
.I ID="SDINT",+$G(ORDIALOG($$PTR($P(TYPE,U)),1))=0,$P($G(RESULT($P(TYPE,U,2))),U)=0 Q
.I $P($G(RESULT($P(TYPE,U,2))),U)'="" S ORDIALOG($$PTR($P(TYPE,U)),1)=$P($G(RESULT($P(TYPE,U,2))),U) Q
.I $G(ORDIALOG($$PTR($P(TYPE,U)),1))'="" S ORDIALOG($$PTR($P(TYPE,U)),1)="@"
Q
;
PMPTMAP(ID) ;
I ID="CLINIC" Q "LOCATION"_U_"CLINIC"
I ID="CLINICALLY" Q "CLINICALLY INDICATED DATE"_U_"RTC DATE"
I ID="SDNUM" Q "APPT NUM"_U_"NUMBER APPT"
I ID="SDINT" Q "SCH INTERVAL"_U_"INTERVAL"
I ID="SDCOMMENT" Q "SD COMMENT"_U_"COMMENT"
I ID="YN" Q "YES/NO"_U_"NLT"
Q ""
;
SENDFAIL(ERROR,RESULT) ;
N ORV
S ORV("XQY0")="" D EN^ORERR(ERROR,.ORMSG,.ORV)
;Q:ORTYPE="ORR" Q:'$L($G(ORNMSP))
N OREMSG
;N ORVP,ORTS S:'$G(ORDUZ) ORDUZ=PAT_";DPT(" D:'$G(ORVP) PID
S OREMSG(1)=$$MSH^ORMBLD("SRM","SD")_"|"_$G(RESULT("MSG ID"))
S OREMSG(2)="MSA|AR|"_ERROR_"|||207^"_ERROR
S OREMSG(3)="ERR|^^^"
D MSG^XQOR("OR EVSEND SD",.OREMSG)
Q
;
SENDOK(RESULT) ;
N ORMSG
S ORMSG(1)=$$MSH^ORMBLD("SRM","SD")_"|"_RESULT("MSG ID")
S ORMSG(2)="MSA|AA|OK|||"
D MSG^XQOR("OR EVSEND SD",.ORMSG)
Q
;
PKG(NMSP) ; -- Return Package file ptr for NMSP
N I S I=0
F S I=+$O(^DIC(9.4,"C",NMSP,I)) Q:I<1 Q:'$O(^(I,0)) ;no Addl Prefs
Q I
;
PTR(X) ; -- Return ptr to prompt OR GTX X
Q +$O(^ORD(101.41,"AB","OR GTX "_X,0))
;
VALUE(ID) ; -- Return value of ID in ^OR(100,+ORIFN,4.5,"ID")
N I,Y I '$L($G(ID)) Q ""
S I=+$O(^OR(100,+ORIFN,4.5,"ID",ID,0))
S Y=$G(^OR(100,+ORIFN,4.5,I,1))
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORMSD 10511 printed Apr 09, 2024@21:32:40 Page 2
ORMSD ; SLC/AGP - Process Scheduling ORM msgs ;04/05/18
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**434,475,483**;Dec 17, 1997;Build 45
+2 ;
+3 ;EN builds an results array
+4 ;INPUTS("APPT IEN")=0
+5 ;INPUTS("APPT TYPE")="followup"
+6 ;INPUTS("CLINIC")="240^20 MINUTE"
+7 ;INPUTS("COMMENT")="This is the new comment field"
+8 ;INPUTS("ENTERED BY")="10000000195^PULEO,ANTHONY"
+9 ;INPUTS("INTERVAL")="Q7D"
+10 ;INPUTS("MSG ID")=""
+11 ;INPUTS("DISCONTINUE")=1
+12 ;INPUTS("ENTERED IN ERROR")=1
+13 ;INPUTS("NLT")=1
+14 ;INPUTS("NUMBER APPT")=4
+15 ;INPUTS("ORDER IEN")=14524362
+16 ;INPUTS("PATIENT")="346^"
+17 ;INPUTS("PREREQ",2)="XRAY"
+18 ;INPUTS("PREREQ",3)="VITALS"
+19 ;INPUTS("RTC DATE")=20170524
+20 ;INPUTS("SIGNED BY")=""
+21 ;
+22 ;
UNESC(STR) ;
+1 QUIT $$UNESC^ORHLESC(STR)
+2 ;
CREATACT(NATURE) ;
+1 NEW IEN
+2 SET IEN=$ORDER(^ORD(100.02,"C",NATURE,""))
IF IEN'>0
QUIT 0
+3 IF +$PIECE($GET(^ORD(100.02,IEN,1)),U)=1
QUIT 1
+4 QUIT 0
+5 ;
EN(MSG) ; -- main entry point for OR RECEIVE where MSG contains HL7 msg
+1 NEW ACTION,AIG,AIL,ARQ,DATE,ENTER,ERROR,FAILMSA,FREQ,HASMSA,INST,MSH,NODE,NUM,NXT,ORMSG,PAT,RESULT,X,PID,PV1,SEG,SIGN
+2 SET ERROR=""
+3 ; MSG="NAME" or MSG(#)=message
SET ORMSG=$SELECT($LENGTH($GET(MSG)):MSG,1:"MSG")
+4 IF '$ORDER(@ORMSG@(0))
DO EN^ORERR("Missing HL7 message",.MSG)
QUIT
+5 SET MSH=0
FOR
SET MSH=$ORDER(@ORMSG@(MSH))
if MSH'>0
QUIT
if $EXTRACT(@ORMSG@(MSH),1,3)="MSH"
QUIT
+6 IF 'MSH
DO EN^ORERR("Missing or invalid MSH segment",.MSG)
+7 SET X=0
SET FAILMSA=0
SET HASMSA=0
FOR
SET X=$ORDER(@ORMSG@(X))
if X'>0!(ERROR'="")!(HASMSA=1)
QUIT
Begin DoDot:1
+8 SET SEG=$PIECE(@ORMSG@(X),"|")
SET NODE=$PIECE(@ORMSG@(X),"|",2,99)
+9 IF SEG="MSA"
SET HASMSA=1
+10 SET SEG=SEG_"(.RESULT,X,NODE,.ERROR)"
+11 DO @SEG
End DoDot:1
+12 IF FAILMSA=1
DO REJECT(.RESULT)
GOTO ENX
+13 IF HASMSA=1
DO ACCEPT(.RESULT)
GOTO ENX
+14 IF $GET(ERROR)'=""
DO SENDFAIL(.ERROR,.RESULT)
GOTO ENX
+15 IF '$$VALIDATE(.RESULT,.ERROR)
DO SENDFAIL(.ERROR,.RESULT)
GOTO ENX
+16 DO SAVEREC(.RESULT)
+17 DO SENDOK(.RESULT)
ENX ;
+1 QUIT
+2 ;
LASTACT(ORIFN) ;
+1 NEW RESULT
+2 IF ORIFN[";"
SET RESULT=$PIECE(ORIFN,";",2)
GOTO LASTACTX
+3 SET RESULT=$ORDER(^OR(100,ORIFN,8,""),-1)
+4 IF RESULT=""
SET RESULT=1
LASTACTX ;
+1 QUIT RESULT
+2 ;
MSH(RESULT,X,SEG,ERROR) ;
+1 SET RESULT("MSG ID")=$PIECE(SEG,"|",9)
+2 SET RESULT("MSG DATE/TIME")=$$HL7TFM^XLFDT($PIECE(SEG,"|",6),"L")
+3 QUIT
+4 ;
MSA(RESULT,X,SEG,ERROR) ;
+1 NEW STATUS
+2 IF $PIECE(SEG,"|")'="AR"
Begin DoDot:1
+3 SET STATUS=$PIECE(SEG,"|",2)
+4 SET RESULT("APPT IEN")=$PIECE(STATUS,U,2)
End DoDot:1
QUIT
+5 SET RESULT("REJECTION ERROR")=$PIECE(SEG,"|",2)
SET FAILMSA=1
+6 ;S OREASON=RESULT("REJECTION ERROR")
+7 QUIT
+8 ;
SCH(RESULT,X,SEG,ERROR) ;
+1 NEW TIME
+2 SET RESULT("ORDER IEN")=$PIECE(SEG,"|",2)
SET RESULT("APPT IEN")=+$PIECE(SEG,"|",1)
+3 SET RESULT("APPT TYPE")=$PIECE($PIECE(SEG,"|",5),U,2)
+4 SET ACTION=$PIECE(SEG,"|",6)
SET RESULT($SELECT($PIECE(ACTION,U)="S15":"DISCONTINUE",1:"COMPLETE"))=1
+5 IF $PIECE(ACTION,U,2)="PARTIAL"
SET RESULT("PARTIAL")=1
+6 SET DATE=$PIECE(SEG,"|",8)
SET TIME=$PIECE(SEG,"|",9)
+7 IF TIME="T"
SET RESULT("NLT")=1
+8 SET RESULT("RTC DATE")=$$HL7TFM^XLFDT($SELECT(TIME="T":$PIECE(DATE,U,2),1:$PIECE(DATE,U)),"L")
+9 SET FREQ=$PIECE(SEG,"|",10)
SET NUM=+$PIECE(SEG,"|",11)
+10 SET RESULT("NUMBER APPT")=NUM
IF NUM>0
SET RESULT("INTERVAL")=+$EXTRACT(FREQ,2,3)
+11 SET RESULT("SIGNED BY")=$PIECE(SEG,"|",14)
+12 SET RESULT("DISPOSITION BY")=$PIECE(SEG,"|",16)
+13 QUIT
+14 ;
AIL(RESULT,X,SEG,ERROR) ;
+1 SET RESULT("CLINIC")=$PIECE(SEG,"|",3)
+2 QUIT
AIG(RESULT,X,SEG,ERROR) ;
+1 NEW INST,NODE
+2 SET RESULT("PREREQ",$PIECE(SEG,"|"))=$PIECE($PIECE(SEG,"|",2),U,2)
+3 SET INST=0
FOR
SET INST=$ORDER(@ORMSG@(X,INST))
if INST'>0
QUIT
Begin DoDot:1
+4 SET NODE=$PIECE(@ORMSG@(X,INST),"|",2,99)
+5 SET RESULT("PREREQ",$PIECE(NODE,"|"))=$PIECE($PIECE(NODE,"|",2),U,2)
End DoDot:1
+6 QUIT
+7 ;
NTE(RESULT,X,SEG,ERROR) ;
+1 SET RESULT("COMMENT")=$$UNESC($PIECE(SEG,"|",3))
+2 QUIT
+3 ;
+4 ;
PID(RESULT,X,SEG,ERROR) ;
+1 SET RESULT("PATIENT")=$PIECE(SEG,"|",3)_U_$PIECE(SEG,"|",5)
+2 QUIT
+3 ;
PV1(RESULT,X,SEG,ERROR) ; -- Gets Patient location info.
+1 ; may not be needed for scheduling
+2 QUIT
+3 ;
FMDATE(Y) ; -- Convert HL7 date/time to FM format
+1 QUIT $$HL7TFM^XLFDT(Y)
+2 ;
REJECT(RESULT) ;
+1 NEW ORIFN,ORNATR
+2 SET ORIFN=$PIECE($GET(RESULT("MSG ID")),U)
if +ORIFN'>0
QUIT
+3 ;Rejected
if '$GET(ORNATR)
SET ORNATR="X"
+4 SET ^OR(100,+ORIFN,6)=$ORDER(^ORD(100.02,"C",ORNATR,0))_U_U_+$EXTRACT($$NOW^XLFDT,1,12)_U_U_RESULT("REJECTION ERROR")
+5 ;remove fwd ptr if pending renewal
IF $PIECE($GET(^OR(100,+ORIFN,3)),U,11)=2
NEW ORIG
SET ORIG=$PIECE(^(3),U,5)
if ORIG
SET $PIECE(^OR(100,ORIG,3),U,6)=""
+6 SET ORERR=RESULT("REJECTION ERROR")
+7 NEW ORDA
SET ORDA=+$PIECE(ORIFN,";",2)
IF ORDA
Begin DoDot:1
+8 ;request rejected
SET $PIECE(^OR(100,+ORIFN,8,ORDA,0),U,15)=13
+9 if $LENGTH(RESULT("REJECTION ERROR"))
SET ^OR(100,+ORIFN,8,ORDA,1)=RESULT("REJECTION ERROR")
End DoDot:1
+10 DO STATUS^ORCSAVE2(+ORIFN,13)
+11 QUIT
+12 ;
ACCEPT(RESULT) ;
+1 NEW ORIFN
+2 SET ORIFN=$PIECE($GET(RESULT("MSG ID")),U)
+3 IF $PIECE(RESULT("MSG ID"),U,2)'="S05"
Begin DoDot:1
+4 SET ^OR(100,+ORIFN,4)=$GET(RESULT("APPT IEN"))
+5 DO STATUS^ORCSAVE2(+ORIFN,5)
+6 DO DATES^ORCSAVE2(+ORIFN,DT,"")
End DoDot:1
QUIT
+7 DO DCACK(+ORIFN,.RESULT)
+8 QUIT
+9 ;
DCACK(ORIFN,RESULT) ;
+1 NEW ORSTS
+2 ;set status to discontinue used as a variable for future code changes
+3 SET ORSTS=1
+4 DO EXPDT(ORIFN)
+5 DO STATUS^ORCSAVE2(+ORIFN,ORSTS)
+6 IF $GET(RESULT("APPT IEN"))'=""
SET ^OR(100,+ORIFN,4)=RESULT("APPT IEN")
+7 QUIT
+8 ;
GETSTAT(RESULT) ;
+1 IF +$GET(RESULT("DISCONTINUE"))
QUIT $ORDER(^ORD(100.01,"B","DISCONTINUED",""))
+2 IF +$GET(RESULT("PARTIAL"))
QUIT $ORDER(^ORD(100.01,"B","PARTIAL RESULTS",""))
+3 QUIT $ORDER(^ORD(100.01,"B","COMPLETE",""))
+4 ;
EXPDT(ORIFN) ; -- save exp date when dc'd
+1 NEW STOP
SET STOP=$PIECE($GET(^OR(100,+ORIFN,0)),U,9)
+2 IF STOP
IF STOP<$$NOW^XLFDT
IF '$PIECE($GET(^OR(100,+ORIFN,6)),U,6)
SET $PIECE(^(6),U,6)=STOP
+3 QUIT
+4 ;
VALIDATE(RESULT,ERROR) ;
+1 NEW OK,ORIFN,OR3,STS
+2 SET OK=1
+3 IF +$GET(RESULT("CLINIC"))'>0
SET ERROR="Clinic location not defined"
SET OK=0
GOTO VALIDATX
+4 IF '$GET(RESULT("COMPLETE"))
IF '$GET(RESULT("DISCONTINUE"))
SET ERROR="Status not defined"
SET OK=0
GOTO VALIDATX
+5 IF +$GET(RESULT("PATIENT"))'>0
SET ERROR="Patient is not defined"
SET OK=0
GOTO VALIDATX
+6 IF +$GET(RESULT("PATIENT"))_";DPT("'=$PIECE($GET(^OR(100,RESULT("ORDER IEN"),0)),U,2)
SET ERROR="Patient doesn't match"
SET OK=0
GOTO VALIDATX
+7 IF '+$GET(RESULT("DISPOSITION BY"))
SET ERROR="User who disposition the order not defined"
SET OK=0
GOTO VALIDATX
+8 SET ORIFN=RESULT("ORDER IEN")
IF +ORIFN'>0
SET ERROR="Order number not defined"
SET OK=0
GOTO VALIDATX
+9 SET OR3=$GET(^OR(100,+ORIFN,3))
SET STS=$PIECE(OR3,U,3)
+10 IF STS=1!(STS=2)
SET ERROR="Order with a status of "_$SELECT(STS=1:"discontinued",1:"complete")_" cannot be changed"
SET OK=0
GOTO VALIDATX
VALIDATX ;
+1 QUIT OK
+2 ;
SAVEREC(RESULT) ;
+1 NEW C,CREATACT,DISPBY,I,ID,ISTIME,OERR,ORDA,ORDG,ORDIALOG,ORIFN,ORNATR,ORNP,ORNOW,ORPKG,ORSTRT,ORVP,ORWHO,STATUS,TYPE,WHOSIGN,X0,X8
+2 NEW ORLEAD,ORTRAIL
+3 SET ORWHO=+RESULT("DISPOSITION BY")
+4 SET ORNP=ORWHO
+5 SET ORNOW=+$EXTRACT($$NOW^XLFDT,1,12)
+6 SET ORDIALOG=+$ORDER(^ORD(101.41,"AB","SD RTC",0))
+7 SET ORDG=+$ORDER(^ORD(100.98,"B","CLINIC SCHEDULING",0))
+8 SET ORIFN=RESULT("ORDER IEN")
+9 SET ORVP=+RESULT("PATIENT")_";DPT("
+10 SET ORPKG=+$$PKG("SD")
DO GETDLG1^ORCD(ORDIALOG)
DO GETORDER^ORCD(+ORIFN,"ORDIALOG")
+11 ;set ORDIALOG array to values returned from scheduling single instance
+12 SET ORDA=$PIECE(ORIFN,";",2)
IF ORDA=""
SET ORDA=1
+13 SET X0=$GET(^OR(100,+ORIFN,0))
SET X8=$GET(^OR(100,ORIFN,8,ORDA,0))
+14 ;get whosigned and start date for later
+15 SET WHOSIGN=$PIECE(X8,U,5)
SET ORSTRT=$PIECE(X0,U,8)
+16 ;update package reference
+17 SET ^OR(100,+ORIFN,4)=$GET(RESULT("APPT IEN"))
+18 ;create new order action
+19 ;set to complete status until next iteration of VSE
+20 SET STATUS=$$GETSTAT(.RESULT)
+21 SET TYPE=$SELECT(+$GET(RESULT("DISCONTINUE")):"DC",1:"XX")
+22 DO STATUS^ORCSAVE2(ORIFN,STATUS)
+23 SET CREATACT=$$CREATACT("I")
+24 IF CREATACT=1
SET ORDA=$$ACTION^ORCSAVE(TYPE,ORIFN,WHOSIGN,$SELECT(TYPE="DC":"Per Scheduling",1:""),ORNOW,ORWHO)
+25 IF CREATACT=0
SET ORDA=$$LASTACT(ORIFN)
+26 ;if order is not created how to get this to expert system
+27 IF ORDA'>0
SET ORERR="Cannot create new order action"
QUIT
+28 ;update status to compete set indexes
+29 ;I TYPE'="DC" D SETALL^ORDD100(ORIFN)
+30 DO SETALL^ORDD100(ORIFN)
+31 ;set the order as it has been release to scheduling with the update
+32 DO RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,ORWHO,"I")
+33 SET ORNATR="I"
+34 DO SIGSTS^ORCSAVE2(+ORIFN,ORDA)
+35 ;update dates
+36 DO DATES^ORCSAVE2(ORIFN,ORSTRT,ORNOW)
+37 ;set disposition fields
+38 NEW DA,DR,DIE
+39 SET DA(1)=ORIFN
SET DA=ORDA
+40 SET DIE="^OR(100,"_DA(1)_",8,"
+41 SET DR="40////"_ORWHO_";41////"_RESULT("MSG DATE/TIME")
+42 DO ^DIE
+43 SET $PIECE(^OR(100,+ORIFN,8,ORDA,0),U,14)=ORDA
+44 SET $PIECE(^OR(100,+ORIFN,3),U,7)=ORDA
+45 IF TYPE="DC"
Begin DoDot:1
+46 DO CANCEL^ORCSEND(+ORIFN)
+47 DO EN^ORB3(91,+RESULT("PATIENT"),ORIFN,"","Appointment Request Cancelled in Scheduling","NEW,"_ORIFN)
QUIT
End DoDot:1
+48 SET ISTIME=+$GET(ORDIALOG($$PTR("YES/NO"),1))
+49 SET ORLEAD=$SELECT(ISTIME=1:"no later than ",1:"on or around (")
SET ORTRAIL=$SELECT(ISTIME=1:"",1:")")
+50 KILL ^OR(100,+ORIFN,4.5)
DO RESPONSE^ORCSAVE
DO ORDTEXT^ORCSAVE1(+ORIFN_";"_ORDA)
+51 ;update the dialog and package fiels. This may have value in future version of VSE
+52 SET $PIECE(^OR(100,ORIFN,0),U,5)=ORDIALOG_";ORD(101.41,"
SET $PIECE(^(0),U,14)=ORPKG
+53 ;validate display group and update if needed
+54 IF $PIECE(^OR(100,ORIFN,0),U,11)'=ORDG
Begin DoDot:1
+55 NEW DA,DR,DIE
+56 SET DA=ORIFN
SET DR="23////"_ORDG
SET DIE="^OR(100,"
DO ^DIE
End DoDot:1
+57 ;S $P(^(8,ORDA,0),U,14)=ORDA
+58 ;send back ack back, because scheduling is using a SRM message this code is branched from
+59 ;the standard OR HL7 message. This handle in the EN line tag of this routine.
+60 ;S ORIFN=ORIFN_";"_ORDA,ORDCNTRL="SN" ;to send NA msg back
+61 QUIT
+62 ;
UPDRESP(ORIFN,ORDIALOG) ;
+1 NEW C,I,ID,TYPE
+2 FOR ID="LOCATION","CLINICALLY","YN","SDNUM","SDINT","SDCOMMENT"
Begin DoDot:1
+3 SET TYPE=$$PMPTMAP(ID)
IF ID=""
QUIT
+4 IF ID="SDINT"
IF +$GET(ORDIALOG($$PTR($PIECE(TYPE,U)),1))=0
IF $PIECE($GET(RESULT($PIECE(TYPE,U,2))),U)=0
QUIT
+5 IF $PIECE($GET(RESULT($PIECE(TYPE,U,2))),U)'=""
SET ORDIALOG($$PTR($PIECE(TYPE,U)),1)=$PIECE($GET(RESULT($PIECE(TYPE,U,2))),U)
QUIT
+6 IF $GET(ORDIALOG($$PTR($PIECE(TYPE,U)),1))'=""
SET ORDIALOG($$PTR($PIECE(TYPE,U)),1)="@"
End DoDot:1
+7 QUIT
+8 ;
PMPTMAP(ID) ;
+1 IF ID="CLINIC"
QUIT "LOCATION"_U_"CLINIC"
+2 IF ID="CLINICALLY"
QUIT "CLINICALLY INDICATED DATE"_U_"RTC DATE"
+3 IF ID="SDNUM"
QUIT "APPT NUM"_U_"NUMBER APPT"
+4 IF ID="SDINT"
QUIT "SCH INTERVAL"_U_"INTERVAL"
+5 IF ID="SDCOMMENT"
QUIT "SD COMMENT"_U_"COMMENT"
+6 IF ID="YN"
QUIT "YES/NO"_U_"NLT"
+7 QUIT ""
+8 ;
SENDFAIL(ERROR,RESULT) ;
+1 NEW ORV
+2 SET ORV("XQY0")=""
DO EN^ORERR(ERROR,.ORMSG,.ORV)
+3 ;Q:ORTYPE="ORR" Q:'$L($G(ORNMSP))
+4 NEW OREMSG
+5 ;N ORVP,ORTS S:'$G(ORDUZ) ORDUZ=PAT_";DPT(" D:'$G(ORVP) PID
+6 SET OREMSG(1)=$$MSH^ORMBLD("SRM","SD")_"|"_$GET(RESULT("MSG ID"))
+7 SET OREMSG(2)="MSA|AR|"_ERROR_"|||207^"_ERROR
+8 SET OREMSG(3)="ERR|^^^"
+9 DO MSG^XQOR("OR EVSEND SD",.OREMSG)
+10 QUIT
+11 ;
SENDOK(RESULT) ;
+1 NEW ORMSG
+2 SET ORMSG(1)=$$MSH^ORMBLD("SRM","SD")_"|"_RESULT("MSG ID")
+3 SET ORMSG(2)="MSA|AA|OK|||"
+4 DO MSG^XQOR("OR EVSEND SD",.ORMSG)
+5 QUIT
+6 ;
PKG(NMSP) ; -- Return Package file ptr for NMSP
+1 NEW I
SET I=0
+2 ;no Addl Prefs
FOR
SET I=+$ORDER(^DIC(9.4,"C",NMSP,I))
if I<1
QUIT
if '$ORDER(^(I,0))
QUIT
+3 QUIT I
+4 ;
PTR(X) ; -- Return ptr to prompt OR GTX X
+1 QUIT +$ORDER(^ORD(101.41,"AB","OR GTX "_X,0))
+2 ;
VALUE(ID) ; -- Return value of ID in ^OR(100,+ORIFN,4.5,"ID")
+1 NEW I,Y
IF '$LENGTH($GET(ID))
QUIT ""
+2 SET I=+$ORDER(^OR(100,+ORIFN,4.5,"ID",ID,0))
+3 SET Y=$GET(^OR(100,+ORIFN,4.5,I,1))
+4 QUIT Y
