SDHL7APU ;MS/TG,PH - TMP HL7 Routine;OCT 16, 2018
;;5.3;Scheduling;**704,714,773,780,798,810,859,863,879**;Aug 13, 1993;Build 31
; Integration Agreements:
;
Q
;
;Helper routine to process SIU^S12 messages from the "TMP VISTA" Subscriber protocol
;
MSH(MSH,INP,MSGARY) ;
S MSGARY("HL7EVENT")=$G(MSH(8,1,2))
S MSGARY("HLTHISSITE")=+$G(MSH(5,1,1))
S ^XTMP("SDTMP",+MSH(9))="",$P(^XTMP("SDTMP",0),U,1)=$$FMADD^XLFDT(DT,7) ;773
Q
;
SCH(SCH,INP,MSGARY) ;
N TM,TMM,CONSDSC,CANCODE
S SDAPTYP="A|"
S SDECATID=$G(SCH(6))
S MSGARY("EVENT")=$G(SCH(6,1,1)) ;if the appointment is canceled check for cancel code and cancel reason, they are required
S (SDECCR,CANCODE)=$G(SCH(6,1,2))
I $G(MSGARY("EVENT"))="CANCELED" D
. I $G(SDECCR)="" S ERR=1,ERRTXT="Cancel Reason was null and is required" Q ;859-add reject condition
. S SDECCR=$O(^SD(409.2,"B",$G(CANCODE),0))
. S:(SDECCR)="" SDECCR=11
. S SDECTYP=$G(SCH(6,1,4))
;S SDECNOT=$G(SCH(6,1,5))
S SDECLEN=$G(SCH(9))
;S MSGARY("SDECLENUNITS")=$G(SCH(10))
S TM=$G(SCH(11,1,4))
I $G(SDDDT)="" S:$G(SCH(11,1,8))'="" SDDDT=$G(SCH(11,1,8))
I $G(SDDDT)="" S:$G(SCH(5,1,2))'="" SDDDT=$G(SCH(5,1,2))
S:$G(TM)'="" SDECSTART=$P(TM,":",1,2)_":00.000Z"
;S INP(11)=$G(SDDDT)
S SDREQBY=$G(SCH(16,1,1))
N SCHEMAIL I $G(SCH(13,1,4))'="" D
.S SCHEMAIL=$$LOW^XLFSTR(SCH(13,1,4)),(DUZ,MSGARY("DUZ"))=$O(^VA(200,"ADUPN",$G(SCHEMAIL),""))
S:$G(DUZ)'>0 (DUZ,MSGARY("DUZ"))=.5
N SDTYP S SDTYP=$G(SCH(6,1,4)) ;consistent location for appt type
I $G(SDTYP)="R" D
.S (RTCID,SDCHILD)=$G(SCH(7,1,1)),SDPARENT=$G(SCH(24,1,1))
.S:$G(SDCHILD)="" (RTCID,SDCHILD)=$G(SCH(7,1,4))
.S SDAPTYP="R|"_$G(SDCHILD)
.S:$P($G(^SDEC(409.85,$G(SDCHILD),3)),"^",1)>0 SDMTC=1
.I $G(SDPARENT)>0 S:$P($G(^SDEC(409.85,$G(SDPARENT),3)),"^",1)>0 SDMTC=1
S:$G(SDTYP)="" SDTYP="A",SDAPTYP="A|"
S:$G(SDTYP)="A" SDTYP="A",SDAPTYP="A|"
Q
;
SCHNTE(SCHNTE,INP,MSGARY) ;
S SDECNOTE=$G(SCHNTE(3))
I $G(MSGARY("EVENT"))="CANCELED" S SDECNOT=$G(SCHNTE(3))
Q
;
PID(PID,INP,MSGARY) ;
S MSGARY("MPI")=$G(PID(3,1,1))
S DFN=$$GETDFN^MPIF001(MSGARY("MPI"))
Q
;
PV1(PV1,INP,MSGARY) ;
Q
;
OBX(OBX,INP) ;
Q
;
RGS(RGS,CNT,INP) ;
S:$D(RGS) RGS(CNT,1)=1
S MSGARY("FACILITYIEN")=$G(RGS(1,3))
Q
;
AIS(AIS,CNT,INP,MSGARY) ;
S:$D(AIS) AIS(CNT,1)=1
Q
;
AISNTE(AISNTE,CNT,INP) ;
S:$D(AISNTE) AISNTE(CNT,1)=1
Q
;
AIG(AIG,CNT,INP) ;
S:$D(AIG) AIG(CNT,1)=1
Q
;
AIGNTE(AIGNTE,CNT,INP) ;
S:$D(AIGNTE) AIGNTE(CNT,1)=1
Q
;
AIL(AIL,CNT,INP,MSGARY) ;
S:$D(AIL) AIL(CNT,1)=1
N STCREC
S STCREC=""
S INP(6)=$G(AIL(1,3,1,1))
S (SDCL)=$G(AIL(1,3,1,1))
S:$G(AIL(2,3,1,1))'="" SDCL2=$G(AIL(2,3,1,1))
S:$G(SDCL2)=$G(SDCL) SDCL3=1
S INP(4)=$$NAME^XUAF4(+$G(AIL(1,3,1,4)))
;CLINIC STOP CODE
D GETSTC^SDECCON(.STCREC,$P($G(SDCL),U,1))
I $G(AIL(1,4,1,2))="C" D
.N XSDDDT,GMRDA
.S GMRDA=$G(AIL(1,4,1,1)) S:$$LOW^XLFSTR($G(GMRDA))="undefined" GMRDA=""
.S XSDDDT=$$GET1^DIQ(123,$G(GMRDA)_",",17,"I") S SDDDT=$$FMTE^XLFDT(XSDDDT)
.S SDAPTYP="C|"_$G(GMRDA)
.S:$G(GMRDA)=""!($G(GMRDA)'>0) SDAPTYP="A|" ;PB - Oct 24, Patch 714, put in to set SDAPTYP as a walkin - stops any looping issues
S:$G(AIL(1,3,1,4))=$G(AIL(2,3,1,4)) INTRA=1
I $G(AIL(1,4,1,2))="A" S SDAPTYP="A|"
I $G(AIL(1,4,1,2))="R" S SDAPTYP="R|"_$G(AIL(1,4,1,4))
Q
;
AILNTE(AILNTE,CNT,INP) ;
S:$D(AILNTE) AILNTE(CNT,1)=1
S AILNTE=$G(AILNTE(1,3,2))
I AILNTE="" S AILNTE=$G(AILNTE(1,3))
Q
;
AIP(AIP,CNT,INP,MSGARY) ;
S:$D(AIP) AIP(CNT,1)=1
S MSGARY("PROVIEN")=$G(AIP(1,3))
Q
;
AIPNTE(AIPNTE,CNT,INP,MSGARY) ;
S:$D(AIPNTE) AIPNTE(CNT,1)=1
Q
;
VALIDMSG(MSGROOT,QRY,XMT,ERR) ;Validate message
;
; Messages handled: SIU^S12
;
; SIU query messages must contain QPD and RCP segments
; Any additional segments are ignored
;
; Input:
; MSGROOT - Root of array holding message
; XMT - Transmission parameters
;
; Output:
;
; XMT - Transmission parameters
; ERR - segment^sequence^field^code^ACK type^error text
;
N MSH,QPD,REQID,REQTYPE,QTAG,QNAME,RDF
N SEGTYPE,CNT
K QRY,ERR
S ERR=""
;
Q 1
;
PARSESEG(SEG,DATA,HL) ;Generic segment parser
;This procedure parses a single HL7 segment and builds an array
;subscripted by the field number containing the data for that field.
; Does not handle segments that span nodes
;
; Input:
; SEG - HL7 segment to parse
; HL - HL7 environment array
;
; Output:
; Function value - field data array [SUB1:field, SUB2:repetition,
; SUB3:component, SUB4:sub-component]
;
N CMP ;component subscript
N CMPVAL ;component value
N FLD ;field subscript
N FLDVAL ;field value
N REP ;repetition subscript
N REPVAL ;repetition value
N SUB ;sub-component subscript
N SUBVAL ;sub-component value
N FS ;field separator
N CS ;component separator
N RS ;repetition separator
N SS ;sub-component separator
;
K DATA
S FS=HL("FS")
S CS=$E(HL("ECH"))
S RS=$E(HL("ECH"),2)
S SS=$E(HL("ECH"),4)
;
S DATA(0)=$P(SEG,FS)
S SEG=$P(SEG,FS,2,9999)
;
F FLD=1:1:$L(SEG,FS) D
. S FLDVAL=$P(SEG,FS,FLD)
. F REP=1:1:$L(FLDVAL,RS) D
. . S REPVAL=$P(FLDVAL,RS,REP)
. . I REPVAL[CS F CMP=1:1:$L(REPVAL,CS) D
. . . S CMPVAL=$P(REPVAL,CS,CMP)
. . . I CMPVAL[SS F SUB=1:1:$L(CMPVAL,SS) D
. . . . S SUBVAL=$P(CMPVAL,SS,SUB)
. . . . I SUBVAL'="" S DATA(FLD,REP,CMP,SUB)=SUBVAL
. . . I '$D(DATA(FLD,REP,CMP)),CMPVAL'="" S DATA(FLD,REP,CMP)=CMPVAL
. . I '$D(DATA(FLD,REP)),REPVAL'="",FLDVAL[RS S DATA(FLD,REP)=REPVAL
. I '$D(DATA(FLD)),FLDVAL'="" S DATA(FLD)=FLDVAL
Q
;
PARSEMSG(MSGROOT,HL) ; Message Parser
; Does not handle segments that span nodes
; Does not handle extremely long segments (uses a local)
; Does not handle long fields (segment parser doesn't)
;
N SEG,CNT,DATA,MSG
F CNT=1:1 Q:'$D(@MSGROOT@(CNT)) M SEG=@MSGROOT@(CNT) D
. D PARSESEG(SEG(0),.DATA,.HL)
. K @MSGROOT@(CNT)
. I DATA(0)'="" M @MSGROOT@(CNT)=DATA
. Q:'$D(SEG(1))
. Q
Q
;
SEND() ;
Q
ACKIN ;
Q
INP ; set up the INP array for calling ARSET^SDECAR2 to update the RTC orders
N NODE3,INTV,NUMAPT,ORDATE
K INP
S SDPARENT=$G(SDPARENT) ;879
I SDPARENT>0 S NODE3=$G(^SDEC(409.85,SDPARENT,3)),INTV=$P(NODE3,"^",2),NUMAPT=$P(NODE3,"^",3) ;879 define numapt
S INP(1)=$P(SDAPTYP,"|",2) ;If NO ien passed in this will be null so it will be added. 810-change 1st piece to use 2nd piece. IEN for file (#409.85)
S INP(2)=$G(DFN)
D NOW^%DTC S NOW=$$HTFM^XLFDT($H),INP(3)=$$FMTE^XLFDT(NOW)
;NEEDS THE TEXT INSTITUTION NAME
S INP(4)=$$NAME^XUAF4(+$G(DUZ(2))) ;Required, DUZ(2) is the signed on users division they are signed into, +DUZ(2) is the parent station number
S INP(5)=$S($G(AIL(1,4,1,2))="R":"RTC",1:"APPT") ;879
S INP(6)=$G(SDCL)
S INP(7)="" ;null for TMP appointments or can we get this from the original RTC order?
S INP(8)="FUTURE"
N X11 S X11=$P($G(SDAPTYP),"|") S:$G(X11)="" X11="A"
S:$G(MSGARY("PROVIEN"))>0 INP(10)=$$GET1^DIQ(200,$G(MSGARY("PROVIEN"))_",",.01,"E")
S INP(9)=$S($G(SDMTC):"PROVIDER",X11="A":"PATIENT",1:"PROVIDER") ;request by provider or patient. RTC orders and consults will always be PROVIDER otherwise it is PATIENT
S:$G(MSGARY("PROVIEN"))>0 INP(10)=$$GET1^DIQ(200,$G(MSGARY("PROVIEN"))_",",.01,"E") ;Provider name - needs to be in lastname,firstname middle initial.
S SDDDT=$G(SCH(5,1,2))
S:$G(SDDDT)="" SDDDT=$G(SCH(11,1,8))
S:$G(SDDDT)="" SDDDT=$P($G(SDECSTART),"T",1) ; Clinically Indicate Date for first appointment in the sequence, each of the remaining appointments have to be calculated
S INP(11)=$G(SDDDT)
S INP(12)=$G(SDECNOTE) ; RTC comments these are different than the comments that are stored in in file 44 appointment multiple.
S PCE="" S PCE=$P($G(^DPT(DFN,"ENR")),U,1) I PCE'="" D
.S INP(13)=$$GET1^DIQ(27.11,PCE,.07,"E")
S SDMRTC=$G(SDMRTC) S:$G(SDMRTC)]"" SDMRTC=$S(SDMRTC=1:"YES",SDMRTC=0:"NO",1:"NO") ; SDMRTC=YES if MRTC
I SDMRTC="YES" D ;879 Do only when MRTC
.S INP(14)=SDMRTC
.S INP(15)=$G(INTV) ;If MRTC, the interval in days between appointments
.S INP(16)=$G(NUMAPT) ;If MRTC, appointments needed number for this MRTC
S INP(17)="" ;null for TMP
N SCXX S SCXX=$S(SDPARENT>0:$$GET1^DIQ(409.85,SDPARENT_",",15,"I"),1:0)
S INP(18)=$S($G(SCXX)=1:"YES",1:"NO") ;is this service connected? we can get this from the parent
S SCPERC=0
S SCPERC=$P(^DPT($G(INP(2)),.3),"^",2)
S INP(19)=SCPERC
S INP(22)="9"
S INP(23)="NEW"
I SDPARENT,($G(AIL(1,4,1,2))="R")!($G(AIL(1,2))="R") D
.S INP(25)=SDPARENT
.S:SDPARENT>0 INP(28)=$P($G(^SDEC(409.85,SDPARENT,7)),U,1) ; this is the CPRS order number
.S:$G(INP(28))>0 INP(26)=$P($G(^SDEC(409.85,SDPARENT,7)),U,2)
Q
ARSET(X) ; set the appointment requests into 409.85
Q
S STOP=0
I $G(X)'>0 Q STOP
I $G(^SDEC(409.85,X,0))="" Q STOP
I $G(^SDEC(409.85,X,3),"^")=1 D ; it is a multiple appointment rtc order
.S INTV=$P(^SDEC(409.85,X,3),"^",2),NUMAPT=$P(^SDEC(409.85,X,3),"^",3)
Q
LOADMSG(MSGROOT) ; Load HL7 message into temporary global for processing
;
;This subroutine assumes that all VistA HL7 environment variables are
;properly initialized and will produce a fatal error if they aren't.
;
N CNT,SEG
K @MSGROOT
F SEG=1:1 X HLNEXT Q:HLQUIT'>0 D
. S CNT=0
. S @MSGROOT@(SEG,CNT)=HLNODE
. F S CNT=$O(HLNODE(CNT)) Q:'CNT S @MSGROOT@(SEG,CNT)=HLNODE(CNT)
. Q
Q
LOADXMT(HL,XMT) ;Set HL dependent XMT values
;
; The HL array and variables are expected to be defined. If not,
; message processing will fail. These references should not be
; wrapped in $G, as null values will simply postpone the failure to
; a point that will be harder to diagnose. Except HL("APAT") which
; is not defined on synchronous calls.
;
; Integration Agreements:
; 1373 : Reference to PROTOCOL file #101
;
N SUBPROT,RESPIEN,RESP0
;S HL("EID")=$$FIND1^DIC(101,,,"TMP QBP-Q13 Event Driver")
;S HL("EIDS")=$$FIND1^DIC(101,,,"TMP QBP-Q13 Subscriber")
S HL("EID")=$$FIND1^DIC(101,,,"SD TMP S12 SERVER EVENT DRIVER")
S HL("EIDS")=$$FIND1^DIC(101,,,"SD TMP S12 CLIENT SUBSCRIBER")
;S HLL("LINKS",1)="SD IFS SUBSCRIBER^TMP_SEND"
S XMT("MID")=HL("MID") ;Message ID
S XMT("MODE")="A" ;Response mode
I $G(HL("APAT"))="" S XMT("MODE")="S" ;Synchronous mode
S XMT("MESSAGE TYPE")=HL("MTN") ;Message type
S XMT("EVENT TYPE")=HL("ETN") ;Event type
S XMT("DELIM")=HL("FS")_HL("ECH") ;HL Delimiters
;S XMT("DELIM")="~^\&"
S XMT("MAX SIZE")=0 ;Default size unlimited
;
; Map response protocol and builder
S SUBPROT=$P(^ORD(101,HL("EIDS"),0),"^")
Q
ERRLKP(ERRTXT) ;
N ERTXI,ERTX1,ERTX2,X,XSP,ERTXT
S ERTXT=ERRTXT
S XSP=0
F ERTXI=1:1 S X=$P($TEXT(ERRS+ERTXI),";;",2) Q:X="" Q:XSP D
. S ERTX1=$P(X,"^",1)
. S ERTX2=$P(X,"^",2)
. I ERTX1'="",ERTX2'="" I ERTXT[ERTX1 S ERTXT=ERTX2,XSP=1
. Q
Q ERTXT
CHKAPT(RET,DFN,CLINID) ;
N XX,STATUS
Q:$G(DFN)'>0
Q:$G(CLINID)'>0
Q:'$D(^DPT(DFN,0))
Q:'$D(^SC(CLINID,0))
S RET=0,STATUS=0
S XX=0 F S XX=$O(^SDEC(409.85,"SCC",DFN,CLINID,XX)) Q:XX'>0 D
. Q:$G(STATUS)=1
. S:$P($G(^SDEC(409.85,XX,"SDAPT")),"^")'="" STATUS=1
. S:$P(^SDEC(409.85,XX,0),"^",17)="O" STATUS=1,RET=XX
Q RET
STRIP(SDECZ) ;Replace control characters with spaces
N SDECI
F SDECI=1:1:$L(SDECZ) I (32>$A($E(SDECZ,SDECI))) S SDECZ=$E(SDECZ,1,SDECI-1)_" "_$E(SDECZ,SDECI+1,999)
Q SDECZ
;
RESLKUP(CLINID) ;
;uses the CLINID to lookup the clinic in the SDEC RESOURCE FILE
N STOP,XX
K RET,RET1
S RET=0
I $G(CLINID)'>0 S RET="0^Invalid Clinic ID" Q
I '$D(^SC(CLINID,0)) S RET="0^Clinic is not in the Hospital Location file" Q
S (STOP,XX)=0 F S XX=$O(^SDEC(409.831,"ALOC",CLINID,XX)) Q:XX'>0 D
. Q:$G(STOP)=1
. I $P($G(^SDEC(409.831,XX,0)),"^",11)["SC(" S STOP=1,RET=XX
S RET1=RET
Q RET1
GETAPT(URL,SDCL,SDECSTART) ;
N STOP,SNODE,CNODE,XX
S STOP=0
Q:$L(URL)'>0 ;if no url, nothing to do here
Q:$L(SDCL)'>0 ;SDCL is required
Q:'$D(^SC(SDCL,0)) ;Clinic doesn't exist
Q:'$D(^SC(SDCL,"S",SDECSTART)) ; Appointment doesnt' exist
S XX=0 F S XX=$O(^SC(SDCL,"S",SDECSTART,1,XX)) Q:XX'>0 D ;Get the correct appointment node for the patient
.I $P(^SC(SDCL,"S",SDECSTART,1,XX,0),"^")=DFN D
. . S SNODE=$G(^SC(SDCL,"S",SDECSTART,1,XX,0))
. . S CNODE=$P($G(^SC(SDCL,"S",SDECSTART,1,XX,"CONS")),"^")
. . S ^SC(SDCL,"S",SDECSTART,1,XX,"URL")=$G(URL)
. . S STOP=1
Q STOP
CHKLL(X) ;check setup of Logical Link
;input value: X = institution number or name
;return value: 1 = setup OK
; 0 = LL setup incorrect
N HLRESLT
D LINK^HLUTIL3(X,.HLRESLT)
S X=+$O(HLRESLT(0)) Q:'X 0
;
Q $$LLOK^HLCSLM(X)
SENDERR(ERR) ; Send for unsuccessful response
K @MSGROOT
;879 discovered when we have any errors that halts make appt, (e.g. patient already has appt this time), then this newly stubbed in open REQ rec needs to be closed as "NN" no longer needed.
I $G(REQIEN) N RET,INPA S INPA(1)=REQIEN,INPA(2)="NN",INPA(3)=$G(DUZ),DUZ(2)=$G(STA),INPA(4)=$$FMTE^XLFDT(DT) D ARCLOSE^SDECAR(.RET,.INPA)
D INIT^HLFNC2(EIN,.HL)
S HL("FS")="|",HL("ECH")="^~\&"
S CNT=1,@MSGROOT@(CNT)=$$MSA^SDTMBUS($G(HL("MID")),ERR,.HL),LEN=$L(@MSGROOT@(CNT))
F IX=1:1:CNT S HLA("HLS",IX)=$G(@MSGROOT@(IX))
M HLA("HLA")=HLA("HLS")
D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.MYRESULT)
K @MSGROOT
Q
DUZ ; send error nak back if user not on system
S ERR="MSA^1^^100^AE^SCHEDULER NOT AUTHORIZED ON THIS VISTA"
D SENDERR^SDHL7APU(ERR)
K @MSGROOT
Q
APPTYPE(CL) ;Determines APPTYPE by STOP CODES associated with CLINIC (SD*5.3*780)
;Returns 1 if STOP CODE indicates Appointment Type equal to 1 (Compensation & Pension)
N SCSPTR,SCS,SC0
S SC0=$G(^SC(CL,0)),SCSPTR=$P(SC0,U,18),SCS=$$GET1^DIQ(40.7,$G(SCSPTR)_",",1,"I")
I SCS>443,SCS<448 Q 1
Q 0
GETSTA(STA) ;Return Parent STA or self if No parent
N PSTA S:($E(STA,4,5)="A")!($E(STA,4,5)="B") STA=+STA S PSTA=+$P($$PRNT^XUAF4(STA),U,2)
Q $S(PSTA:PSTA,1:STA)
;
ERRS ;
;;already has appt at^Patient already has an appt at that datetime
;;already has appt at^Patient already has an appt
;;SDEC07 Error: This RTC request has been closed^This RTC request has been closed
;;SDEC07 Error: Invalid Start Time^Invalid Start Time
;;SDEC07 Error: Invalid End Time^Invalid End Time
;;SDEC07: Patient ID required.^Patient ID required
;;SDEC07 Error: Invalid Patient ID^Invalid Patient ID
;;Patient is being edited. Try again later.^Patient is being edited.
;;SDEC07 Error: Invalid Resource ID^Invalid Resource ID
;;SDEC07 Error: Unable to add appointment -- invalid Resource entry.^Unable to add appt - invalid Resource entry
;;SDEC07 Error: Appointment length must be between 5 - 120.^Appointment length must be between 5 - 120
;;SDEC07 Error: Invalid appointment request type.^Invalid appointment request type
;;THAT TIME IS NOT WITHIN SCHEDULED PERIOD^That time not within scheduled period
;;SDEC07 Error: Invalid clinic ID.^Invalid clinic ID
;;is an inactive clinic.^Clinic is inactive
;;Another user is working with this patient's record. Please try again later^Patient record locked
;;SDEC07 Error: Unable to add appointment to SDEC APPOINTMENT file.^Can't add appointment to SDEC APPOINTMENT file
;;Invalid Clinic ID - Cannot determine if Overbook is allowed.^Cannot determine if Overbook is allowed.
;;Invalid Appointment Date.^Invalid Appointment Date.
;;SDEC08: Invalid Appointment ID^Invalid Appointment ID
;;Error adding date to file 44: Clinic^Error adding date to file 44
;;SDEC08: Invalid status type^Invalid status type
;;Another user is working with this patient's record. Please try again later^Patient record locked
;;Invalid Appointment ID.^Invalid Appointment ID
;;Appointment is not Cancelled.^Appointment is not Cancelled
;;Cancelled by patient appointment cannot be uncancelled.^Cannot be uncancelled
;;FileMan add toS DPT error: Patient=^FileMan add toS DPT error
;;Another user is working with this patient's record. Please try again later^Patient record locked
;;
;
ACK ;****BUILD THE RESPONSE MSA (Cont. of SDHL7APT)
S ERRTXT=$$ERRLKP^SDHL7APU(ERRTXT) ; move to this tag from sdhl7apt
S ERRTXT=$$STRIP^SDHL7APU(ERRTXT)
;
K @MSGROOT
N HLA,ERR,LEN,FOUNDCN
D INIT^HLFNC2(EIN,.HL)
S HL("FS")="|",HL("ECH")="^~\&"
S (ERR,FOUNDCN)=0
S HL("MID")=$S($G(HL("MID")):HL("MID"),1:ACKMSG)
S HLA("HLA",1)="MSA"_HL("FS")_$S(ERRCND:"AE",1:"AA")_HL("FS")_HL("MID")_HL("FS")_$S(ERRCND:$E(ERRTXT,1,99),1:"")_HL("FS") ;879 incr to 99
D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.MYRESULT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDHL7APU 16900 printed Aug 26, 2025@23:14:33 Page 2
SDHL7APU ;MS/TG,PH - TMP HL7 Routine;OCT 16, 2018
+1 ;;5.3;Scheduling;**704,714,773,780,798,810,859,863,879**;Aug 13, 1993;Build 31
+2 ; Integration Agreements:
+3 ;
+4 QUIT
+5 ;
+6 ;Helper routine to process SIU^S12 messages from the "TMP VISTA" Subscriber protocol
+7 ;
MSH(MSH,INP,MSGARY) ;
+1 SET MSGARY("HL7EVENT")=$GET(MSH(8,1,2))
+2 SET MSGARY("HLTHISSITE")=+$GET(MSH(5,1,1))
+3 ;773
SET ^XTMP("SDTMP",+MSH(9))=""
SET $PIECE(^XTMP("SDTMP",0),U,1)=$$FMADD^XLFDT(DT,7)
+4 QUIT
+5 ;
SCH(SCH,INP,MSGARY) ;
+1 NEW TM,TMM,CONSDSC,CANCODE
+2 SET SDAPTYP="A|"
+3 SET SDECATID=$GET(SCH(6))
+4 ;if the appointment is canceled check for cancel code and cancel reason, they are required
SET MSGARY("EVENT")=$GET(SCH(6,1,1))
+5 SET (SDECCR,CANCODE)=$GET(SCH(6,1,2))
+6 IF $GET(MSGARY("EVENT"))="CANCELED"
Begin DoDot:1
+7 ;859-add reject condition
IF $GET(SDECCR)=""
SET ERR=1
SET ERRTXT="Cancel Reason was null and is required"
QUIT
+8 SET SDECCR=$ORDER(^SD(409.2,"B",$GET(CANCODE),0))
+9 if (SDECCR)=""
SET SDECCR=11
+10 SET SDECTYP=$GET(SCH(6,1,4))
End DoDot:1
+11 ;S SDECNOT=$G(SCH(6,1,5))
+12 SET SDECLEN=$GET(SCH(9))
+13 ;S MSGARY("SDECLENUNITS")=$G(SCH(10))
+14 SET TM=$GET(SCH(11,1,4))
+15 IF $GET(SDDDT)=""
if $GET(SCH(11,1,8))'=""
SET SDDDT=$GET(SCH(11,1,8))
+16 IF $GET(SDDDT)=""
if $GET(SCH(5,1,2))'=""
SET SDDDT=$GET(SCH(5,1,2))
+17 if $GET(TM)'=""
SET SDECSTART=$PIECE(TM,":",1,2)_":00.000Z"
+18 ;S INP(11)=$G(SDDDT)
+19 SET SDREQBY=$GET(SCH(16,1,1))
+20 NEW SCHEMAIL
IF $GET(SCH(13,1,4))'=""
Begin DoDot:1
+21 SET SCHEMAIL=$$LOW^XLFSTR(SCH(13,1,4))
SET (DUZ,MSGARY("DUZ"))=$ORDER(^VA(200,"ADUPN",$GET(SCHEMAIL),""))
End DoDot:1
+22 if $GET(DUZ)'>0
SET (DUZ,MSGARY("DUZ"))=.5
+23 ;consistent location for appt type
NEW SDTYP
SET SDTYP=$GET(SCH(6,1,4))
+24 IF $GET(SDTYP)="R"
Begin DoDot:1
+25 SET (RTCID,SDCHILD)=$GET(SCH(7,1,1))
SET SDPARENT=$GET(SCH(24,1,1))
+26 if $GET(SDCHILD)=""
SET (RTCID,SDCHILD)=$GET(SCH(7,1,4))
+27 SET SDAPTYP="R|"_$GET(SDCHILD)
+28 if $PIECE($GET(^SDEC(409.85,$GET(SDCHILD),3)),"^",1)>0
SET SDMTC=1
+29 IF $GET(SDPARENT)>0
if $PIECE($GET(^SDEC(409.85,$GET(SDPARENT),3)),"^",1)>0
SET SDMTC=1
End DoDot:1
+30 if $GET(SDTYP)=""
SET SDTYP="A"
SET SDAPTYP="A|"
+31 if $GET(SDTYP)="A"
SET SDTYP="A"
SET SDAPTYP="A|"
+32 QUIT
+33 ;
SCHNTE(SCHNTE,INP,MSGARY) ;
+1 SET SDECNOTE=$GET(SCHNTE(3))
+2 IF $GET(MSGARY("EVENT"))="CANCELED"
SET SDECNOT=$GET(SCHNTE(3))
+3 QUIT
+4 ;
PID(PID,INP,MSGARY) ;
+1 SET MSGARY("MPI")=$GET(PID(3,1,1))
+2 SET DFN=$$GETDFN^MPIF001(MSGARY("MPI"))
+3 QUIT
+4 ;
PV1(PV1,INP,MSGARY) ;
+1 QUIT
+2 ;
OBX(OBX,INP) ;
+1 QUIT
+2 ;
RGS(RGS,CNT,INP) ;
+1 if $DATA(RGS)
SET RGS(CNT,1)=1
+2 SET MSGARY("FACILITYIEN")=$GET(RGS(1,3))
+3 QUIT
+4 ;
AIS(AIS,CNT,INP,MSGARY) ;
+1 if $DATA(AIS)
SET AIS(CNT,1)=1
+2 QUIT
+3 ;
AISNTE(AISNTE,CNT,INP) ;
+1 if $DATA(AISNTE)
SET AISNTE(CNT,1)=1
+2 QUIT
+3 ;
AIG(AIG,CNT,INP) ;
+1 if $DATA(AIG)
SET AIG(CNT,1)=1
+2 QUIT
+3 ;
AIGNTE(AIGNTE,CNT,INP) ;
+1 if $DATA(AIGNTE)
SET AIGNTE(CNT,1)=1
+2 QUIT
+3 ;
AIL(AIL,CNT,INP,MSGARY) ;
+1 if $DATA(AIL)
SET AIL(CNT,1)=1
+2 NEW STCREC
+3 SET STCREC=""
+4 SET INP(6)=$GET(AIL(1,3,1,1))
+5 SET (SDCL)=$GET(AIL(1,3,1,1))
+6 if $GET(AIL(2,3,1,1))'=""
SET SDCL2=$GET(AIL(2,3,1,1))
+7 if $GET(SDCL2)=$GET(SDCL)
SET SDCL3=1
+8 SET INP(4)=$$NAME^XUAF4(+$GET(AIL(1,3,1,4)))
+9 ;CLINIC STOP CODE
+10 DO GETSTC^SDECCON(.STCREC,$PIECE($GET(SDCL),U,1))
+11 IF $GET(AIL(1,4,1,2))="C"
Begin DoDot:1
+12 NEW XSDDDT,GMRDA
+13 SET GMRDA=$GET(AIL(1,4,1,1))
if $$LOW^XLFSTR($GET(GMRDA))="undefined"
SET GMRDA=""
+14 SET XSDDDT=$$GET1^DIQ(123,$GET(GMRDA)_",",17,"I")
SET SDDDT=$$FMTE^XLFDT(XSDDDT)
+15 SET SDAPTYP="C|"_$GET(GMRDA)
+16 ;PB - Oct 24, Patch 714, put in to set SDAPTYP as a walkin - stops any looping issues
if $GET(GMRDA)=""!($GET(GMRDA)'>0)
SET SDAPTYP="A|"
End DoDot:1
+17 if $GET(AIL(1,3,1,4))=$GET(AIL(2,3,1,4))
SET INTRA=1
+18 IF $GET(AIL(1,4,1,2))="A"
SET SDAPTYP="A|"
+19 IF $GET(AIL(1,4,1,2))="R"
SET SDAPTYP="R|"_$GET(AIL(1,4,1,4))
+20 QUIT
+21 ;
AILNTE(AILNTE,CNT,INP) ;
+1 if $DATA(AILNTE)
SET AILNTE(CNT,1)=1
+2 SET AILNTE=$GET(AILNTE(1,3,2))
+3 IF AILNTE=""
SET AILNTE=$GET(AILNTE(1,3))
+4 QUIT
+5 ;
AIP(AIP,CNT,INP,MSGARY) ;
+1 if $DATA(AIP)
SET AIP(CNT,1)=1
+2 SET MSGARY("PROVIEN")=$GET(AIP(1,3))
+3 QUIT
+4 ;
AIPNTE(AIPNTE,CNT,INP,MSGARY) ;
+1 if $DATA(AIPNTE)
SET AIPNTE(CNT,1)=1
+2 QUIT
+3 ;
VALIDMSG(MSGROOT,QRY,XMT,ERR) ;Validate message
+1 ;
+2 ; Messages handled: SIU^S12
+3 ;
+4 ; SIU query messages must contain QPD and RCP segments
+5 ; Any additional segments are ignored
+6 ;
+7 ; Input:
+8 ; MSGROOT - Root of array holding message
+9 ; XMT - Transmission parameters
+10 ;
+11 ; Output:
+12 ;
+13 ; XMT - Transmission parameters
+14 ; ERR - segment^sequence^field^code^ACK type^error text
+15 ;
+16 NEW MSH,QPD,REQID,REQTYPE,QTAG,QNAME,RDF
+17 NEW SEGTYPE,CNT
+18 KILL QRY,ERR
+19 SET ERR=""
+20 ;
+21 QUIT 1
+22 ;
PARSESEG(SEG,DATA,HL) ;Generic segment parser
+1 ;This procedure parses a single HL7 segment and builds an array
+2 ;subscripted by the field number containing the data for that field.
+3 ; Does not handle segments that span nodes
+4 ;
+5 ; Input:
+6 ; SEG - HL7 segment to parse
+7 ; HL - HL7 environment array
+8 ;
+9 ; Output:
+10 ; Function value - field data array [SUB1:field, SUB2:repetition,
+11 ; SUB3:component, SUB4:sub-component]
+12 ;
+13 ;component subscript
NEW CMP
+14 ;component value
NEW CMPVAL
+15 ;field subscript
NEW FLD
+16 ;field value
NEW FLDVAL
+17 ;repetition subscript
NEW REP
+18 ;repetition value
NEW REPVAL
+19 ;sub-component subscript
NEW SUB
+20 ;sub-component value
NEW SUBVAL
+21 ;field separator
NEW FS
+22 ;component separator
NEW CS
+23 ;repetition separator
NEW RS
+24 ;sub-component separator
NEW SS
+25 ;
+26 KILL DATA
+27 SET FS=HL("FS")
+28 SET CS=$EXTRACT(HL("ECH"))
+29 SET RS=$EXTRACT(HL("ECH"),2)
+30 SET SS=$EXTRACT(HL("ECH"),4)
+31 ;
+32 SET DATA(0)=$PIECE(SEG,FS)
+33 SET SEG=$PIECE(SEG,FS,2,9999)
+34 ;
+35 FOR FLD=1:1:$LENGTH(SEG,FS)
Begin DoDot:1
+36 SET FLDVAL=$PIECE(SEG,FS,FLD)
+37 FOR REP=1:1:$LENGTH(FLDVAL,RS)
Begin DoDot:2
+38 SET REPVAL=$PIECE(FLDVAL,RS,REP)
+39 IF REPVAL[CS
FOR CMP=1:1:$LENGTH(REPVAL,CS)
Begin DoDot:3
+40 SET CMPVAL=$PIECE(REPVAL,CS,CMP)
+41 IF CMPVAL[SS
FOR SUB=1:1:$LENGTH(CMPVAL,SS)
Begin DoDot:4
+42 SET SUBVAL=$PIECE(CMPVAL,SS,SUB)
+43 IF SUBVAL'=""
SET DATA(FLD,REP,CMP,SUB)=SUBVAL
End DoDot:4
+44 IF '$DATA(DATA(FLD,REP,CMP))
IF CMPVAL'=""
SET DATA(FLD,REP,CMP)=CMPVAL
End DoDot:3
+45 IF '$DATA(DATA(FLD,REP))
IF REPVAL'=""
IF FLDVAL[RS
SET DATA(FLD,REP)=REPVAL
End DoDot:2
+46 IF '$DATA(DATA(FLD))
IF FLDVAL'=""
SET DATA(FLD)=FLDVAL
End DoDot:1
+47 QUIT
+48 ;
PARSEMSG(MSGROOT,HL) ; Message Parser
+1 ; Does not handle segments that span nodes
+2 ; Does not handle extremely long segments (uses a local)
+3 ; Does not handle long fields (segment parser doesn't)
+4 ;
+5 NEW SEG,CNT,DATA,MSG
+6 FOR CNT=1:1
if '$DATA(@MSGROOT@(CNT))
QUIT
MERGE SEG=@MSGROOT@(CNT)
Begin DoDot:1
+7 DO PARSESEG(SEG(0),.DATA,.HL)
+8 KILL @MSGROOT@(CNT)
+9 IF DATA(0)'=""
MERGE @MSGROOT@(CNT)=DATA
+10 if '$DATA(SEG(1))
QUIT
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
SEND() ;
+1 QUIT
ACKIN ;
+1 QUIT
INP ; set up the INP array for calling ARSET^SDECAR2 to update the RTC orders
+1 NEW NODE3,INTV,NUMAPT,ORDATE
+2 KILL INP
+3 ;879
SET SDPARENT=$GET(SDPARENT)
+4 ;879 define numapt
IF SDPARENT>0
SET NODE3=$GET(^SDEC(409.85,SDPARENT,3))
SET INTV=$PIECE(NODE3,"^",2)
SET NUMAPT=$PIECE(NODE3,"^",3)
+5 ;If NO ien passed in this will be null so it will be added. 810-change 1st piece to use 2nd piece. IEN for file (#409.85)
SET INP(1)=$PIECE(SDAPTYP,"|",2)
+6 SET INP(2)=$GET(DFN)
+7 DO NOW^%DTC
SET NOW=$$HTFM^XLFDT($HOROLOG)
SET INP(3)=$$FMTE^XLFDT(NOW)
+8 ;NEEDS THE TEXT INSTITUTION NAME
+9 ;Required, DUZ(2) is the signed on users division they are signed into, +DUZ(2) is the parent station number
SET INP(4)=$$NAME^XUAF4(+$GET(DUZ(2)))
+10 ;879
SET INP(5)=$SELECT($GET(AIL(1,4,1,2))="R":"RTC",1:"APPT")
+11 SET INP(6)=$GET(SDCL)
+12 ;null for TMP appointments or can we get this from the original RTC order?
SET INP(7)=""
+13 SET INP(8)="FUTURE"
+14 NEW X11
SET X11=$PIECE($GET(SDAPTYP),"|")
if $GET(X11)=""
SET X11="A"
+15 if $GET(MSGARY("PROVIEN"))>0
SET INP(10)=$$GET1^DIQ(200,$GET(MSGARY("PROVIEN"))_",",.01,"E")
+16 ;request by provider or patient. RTC orders and consults will always be PROVIDER otherwise it is PATIENT
SET INP(9)=$SELECT($GET(SDMTC):"PROVIDER",X11="A":"PATIENT",1:"PROVIDER")
+17 ;Provider name - needs to be in lastname,firstname middle initial.
if $GET(MSGARY("PROVIEN"))>0
SET INP(10)=$$GET1^DIQ(200,$GET(MSGARY("PROVIEN"))_",",.01,"E")
+18 SET SDDDT=$GET(SCH(5,1,2))
+19 if $GET(SDDDT)=""
SET SDDDT=$GET(SCH(11,1,8))
+20 ; Clinically Indicate Date for first appointment in the sequence, each of the remaining appointments have to be calculated
if $GET(SDDDT)=""
SET SDDDT=$PIECE($GET(SDECSTART),"T",1)
+21 SET INP(11)=$GET(SDDDT)
+22 ; RTC comments these are different than the comments that are stored in in file 44 appointment multiple.
SET INP(12)=$GET(SDECNOTE)
+23 SET PCE=""
SET PCE=$PIECE($GET(^DPT(DFN,"ENR")),U,1)
IF PCE'=""
Begin DoDot:1
+24 SET INP(13)=$$GET1^DIQ(27.11,PCE,.07,"E")
End DoDot:1
+25 ; SDMRTC=YES if MRTC
SET SDMRTC=$GET(SDMRTC)
if $GET(SDMRTC)]""
SET SDMRTC=$SELECT(SDMRTC=1:"YES",SDMRTC=0:"NO",1:"NO")
+26 ;879 Do only when MRTC
IF SDMRTC="YES"
Begin DoDot:1
+27 SET INP(14)=SDMRTC
+28 ;If MRTC, the interval in days between appointments
SET INP(15)=$GET(INTV)
+29 ;If MRTC, appointments needed number for this MRTC
SET INP(16)=$GET(NUMAPT)
End DoDot:1
+30 ;null for TMP
SET INP(17)=""
+31 NEW SCXX
SET SCXX=$SELECT(SDPARENT>0:$$GET1^DIQ(409.85,SDPARENT_",",15,"I"),1:0)
+32 ;is this service connected? we can get this from the parent
SET INP(18)=$SELECT($GET(SCXX)=1:"YES",1:"NO")
+33 SET SCPERC=0
+34 SET SCPERC=$PIECE(^DPT($GET(INP(2)),.3),"^",2)
+35 SET INP(19)=SCPERC
+36 SET INP(22)="9"
+37 SET INP(23)="NEW"
+38 IF SDPARENT
IF ($GET(AIL(1,4,1,2))="R")!($GET(AIL(1,2))="R")
Begin DoDot:1
+39 SET INP(25)=SDPARENT
+40 ; this is the CPRS order number
if SDPARENT>0
SET INP(28)=$PIECE($GET(^SDEC(409.85,SDPARENT,7)),U,1)
+41 if $GET(INP(28))>0
SET INP(26)=$PIECE($GET(^SDEC(409.85,SDPARENT,7)),U,2)
End DoDot:1
+42 QUIT
ARSET(X) ; set the appointment requests into 409.85
+1 QUIT
+2 SET STOP=0
+3 IF $GET(X)'>0
QUIT STOP
+4 IF $GET(^SDEC(409.85,X,0))=""
QUIT STOP
+5 ; it is a multiple appointment rtc order
IF $GET(^SDEC(409.85,X,3),"^")=1
Begin DoDot:1
+6 SET INTV=$PIECE(^SDEC(409.85,X,3),"^",2)
SET NUMAPT=$PIECE(^SDEC(409.85,X,3),"^",3)
End DoDot:1
+7 QUIT
LOADMSG(MSGROOT) ; Load HL7 message into temporary global for processing
+1 ;
+2 ;This subroutine assumes that all VistA HL7 environment variables are
+3 ;properly initialized and will produce a fatal error if they aren't.
+4 ;
+5 NEW CNT,SEG
+6 KILL @MSGROOT
+7 FOR SEG=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+8 SET CNT=0
+9 SET @MSGROOT@(SEG,CNT)=HLNODE
+10 FOR
SET CNT=$ORDER(HLNODE(CNT))
if 'CNT
QUIT
SET @MSGROOT@(SEG,CNT)=HLNODE(CNT)
+11 QUIT
End DoDot:1
+12 QUIT
LOADXMT(HL,XMT) ;Set HL dependent XMT values
+1 ;
+2 ; The HL array and variables are expected to be defined. If not,
+3 ; message processing will fail. These references should not be
+4 ; wrapped in $G, as null values will simply postpone the failure to
+5 ; a point that will be harder to diagnose. Except HL("APAT") which
+6 ; is not defined on synchronous calls.
+7 ;
+8 ; Integration Agreements:
+9 ; 1373 : Reference to PROTOCOL file #101
+10 ;
+11 NEW SUBPROT,RESPIEN,RESP0
+12 ;S HL("EID")=$$FIND1^DIC(101,,,"TMP QBP-Q13 Event Driver")
+13 ;S HL("EIDS")=$$FIND1^DIC(101,,,"TMP QBP-Q13 Subscriber")
+14 SET HL("EID")=$$FIND1^DIC(101,,,"SD TMP S12 SERVER EVENT DRIVER")
+15 SET HL("EIDS")=$$FIND1^DIC(101,,,"SD TMP S12 CLIENT SUBSCRIBER")
+16 ;S HLL("LINKS",1)="SD IFS SUBSCRIBER^TMP_SEND"
+17 ;Message ID
SET XMT("MID")=HL("MID")
+18 ;Response mode
SET XMT("MODE")="A"
+19 ;Synchronous mode
IF $GET(HL("APAT"))=""
SET XMT("MODE")="S"
+20 ;Message type
SET XMT("MESSAGE TYPE")=HL("MTN")
+21 ;Event type
SET XMT("EVENT TYPE")=HL("ETN")
+22 ;HL Delimiters
SET XMT("DELIM")=HL("FS")_HL("ECH")
+23 ;S XMT("DELIM")="~^\&"
+24 ;Default size unlimited
SET XMT("MAX SIZE")=0
+25 ;
+26 ; Map response protocol and builder
+27 SET SUBPROT=$PIECE(^ORD(101,HL("EIDS"),0),"^")
+28 QUIT
ERRLKP(ERRTXT) ;
+1 NEW ERTXI,ERTX1,ERTX2,X,XSP,ERTXT
+2 SET ERTXT=ERRTXT
+3 SET XSP=0
+4 FOR ERTXI=1:1
SET X=$PIECE($TEXT(ERRS+ERTXI),";;",2)
if X=""
QUIT
if XSP
QUIT
Begin DoDot:1
+5 SET ERTX1=$PIECE(X,"^",1)
+6 SET ERTX2=$PIECE(X,"^",2)
+7 IF ERTX1'=""
IF ERTX2'=""
IF ERTXT[ERTX1
SET ERTXT=ERTX2
SET XSP=1
+8 QUIT
End DoDot:1
+9 QUIT ERTXT
CHKAPT(RET,DFN,CLINID) ;
+1 NEW XX,STATUS
+2 if $GET(DFN)'>0
QUIT
+3 if $GET(CLINID)'>0
QUIT
+4 if '$DATA(^DPT(DFN,0))
QUIT
+5 if '$DATA(^SC(CLINID,0))
QUIT
+6 SET RET=0
SET STATUS=0
+7 SET XX=0
FOR
SET XX=$ORDER(^SDEC(409.85,"SCC",DFN,CLINID,XX))
if XX'>0
QUIT
Begin DoDot:1
+8 if $GET(STATUS)=1
QUIT
+9 if $PIECE($GET(^SDEC(409.85,XX,"SDAPT")),"^")'=""
SET STATUS=1
+10 if $PIECE(^SDEC(409.85,XX,0),"^",17)="O"
SET STATUS=1
SET RET=XX
End DoDot:1
+11 QUIT RET
STRIP(SDECZ) ;Replace control characters with spaces
+1 NEW SDECI
+2 FOR SDECI=1:1:$LENGTH(SDECZ)
IF (32>$ASCII($EXTRACT(SDECZ,SDECI)))
SET SDECZ=$EXTRACT(SDECZ,1,SDECI-1)_" "_$EXTRACT(SDECZ,SDECI+1,999)
+3 QUIT SDECZ
+4 ;
RESLKUP(CLINID) ;
+1 ;uses the CLINID to lookup the clinic in the SDEC RESOURCE FILE
+2 NEW STOP,XX
+3 KILL RET,RET1
+4 SET RET=0
+5 IF $GET(CLINID)'>0
SET RET="0^Invalid Clinic ID"
QUIT
+6 IF '$DATA(^SC(CLINID,0))
SET RET="0^Clinic is not in the Hospital Location file"
QUIT
+7 SET (STOP,XX)=0
FOR
SET XX=$ORDER(^SDEC(409.831,"ALOC",CLINID,XX))
if XX'>0
QUIT
Begin DoDot:1
+8 if $GET(STOP)=1
QUIT
+9 IF $PIECE($GET(^SDEC(409.831,XX,0)),"^",11)["SC("
SET STOP=1
SET RET=XX
End DoDot:1
+10 SET RET1=RET
+11 QUIT RET1
GETAPT(URL,SDCL,SDECSTART) ;
+1 NEW STOP,SNODE,CNODE,XX
+2 SET STOP=0
+3 ;if no url, nothing to do here
if $LENGTH(URL)'>0
QUIT
+4 ;SDCL is required
if $LENGTH(SDCL)'>0
QUIT
+5 ;Clinic doesn't exist
if '$DATA(^SC(SDCL,0))
QUIT
+6 ; Appointment doesnt' exist
if '$DATA(^SC(SDCL,"S",SDECSTART))
QUIT
+7 ;Get the correct appointment node for the patient
SET XX=0
FOR
SET XX=$ORDER(^SC(SDCL,"S",SDECSTART,1,XX))
if XX'>0
QUIT
Begin DoDot:1
+8 IF $PIECE(^SC(SDCL,"S",SDECSTART,1,XX,0),"^")=DFN
Begin DoDot:2
+9 SET SNODE=$GET(^SC(SDCL,"S",SDECSTART,1,XX,0))
+10 SET CNODE=$PIECE($GET(^SC(SDCL,"S",SDECSTART,1,XX,"CONS")),"^")
+11 SET ^SC(SDCL,"S",SDECSTART,1,XX,"URL")=$GET(URL)
+12 SET STOP=1
End DoDot:2
End DoDot:1
+13 QUIT STOP
CHKLL(X) ;check setup of Logical Link
+1 ;input value: X = institution number or name
+2 ;return value: 1 = setup OK
+3 ; 0 = LL setup incorrect
+4 NEW HLRESLT
+5 DO LINK^HLUTIL3(X,.HLRESLT)
+6 SET X=+$ORDER(HLRESLT(0))
if 'X
QUIT 0
+7 ;
+8 QUIT $$LLOK^HLCSLM(X)
SENDERR(ERR) ; Send for unsuccessful response
+1 KILL @MSGROOT
+2 ;879 discovered when we have any errors that halts make appt, (e.g. patient already has appt this time), then this newly stubbed in open REQ rec needs to be closed as "NN" no longer needed.
+3 IF $GET(REQIEN)
NEW RET,INPA
SET INPA(1)=REQIEN
SET INPA(2)="NN"
SET INPA(3)=$GET(DUZ)
SET DUZ(2)=$GET(STA)
SET INPA(4)=$$FMTE^XLFDT(DT)
DO ARCLOSE^SDECAR(.RET,.INPA)
+4 DO INIT^HLFNC2(EIN,.HL)
+5 SET HL("FS")="|"
SET HL("ECH")="^~\&"
+6 SET CNT=1
SET @MSGROOT@(CNT)=$$MSA^SDTMBUS($GET(HL("MID")),ERR,.HL)
SET LEN=$LENGTH(@MSGROOT@(CNT))
+7 FOR IX=1:1:CNT
SET HLA("HLS",IX)=$GET(@MSGROOT@(IX))
+8 MERGE HLA("HLA")=HLA("HLS")
+9 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.MYRESULT)
+10 KILL @MSGROOT
+11 QUIT
DUZ ; send error nak back if user not on system
+1 SET ERR="MSA^1^^100^AE^SCHEDULER NOT AUTHORIZED ON THIS VISTA"
+2 DO SENDERR^SDHL7APU(ERR)
+3 KILL @MSGROOT
+4 QUIT
APPTYPE(CL) ;Determines APPTYPE by STOP CODES associated with CLINIC (SD*5.3*780)
+1 ;Returns 1 if STOP CODE indicates Appointment Type equal to 1 (Compensation & Pension)
+2 NEW SCSPTR,SCS,SC0
+3 SET SC0=$GET(^SC(CL,0))
SET SCSPTR=$PIECE(SC0,U,18)
SET SCS=$$GET1^DIQ(40.7,$GET(SCSPTR)_",",1,"I")
+4 IF SCS>443
IF SCS<448
QUIT 1
+5 QUIT 0
GETSTA(STA) ;Return Parent STA or self if No parent
+1 NEW PSTA
if ($EXTRACT(STA,4,5)="A")!($EXTRACT(STA,4,5)="B")
SET STA=+STA
SET PSTA=+$PIECE($$PRNT^XUAF4(STA),U,2)
+2 QUIT $SELECT(PSTA:PSTA,1:STA)
+3 ;
ERRS ;
+1 ;;already has appt at^Patient already has an appt at that datetime
+2 ;;already has appt at^Patient already has an appt
+3 ;;SDEC07 Error: This RTC request has been closed^This RTC request has been closed
+4 ;;SDEC07 Error: Invalid Start Time^Invalid Start Time
+5 ;;SDEC07 Error: Invalid End Time^Invalid End Time
+6 ;;SDEC07: Patient ID required.^Patient ID required
+7 ;;SDEC07 Error: Invalid Patient ID^Invalid Patient ID
+8 ;;Patient is being edited. Try again later.^Patient is being edited.
+9 ;;SDEC07 Error: Invalid Resource ID^Invalid Resource ID
+10 ;;SDEC07 Error: Unable to add appointment -- invalid Resource entry.^Unable to add appt - invalid Resource entry
+11 ;;SDEC07 Error: Appointment length must be between 5 - 120.^Appointment length must be between 5 - 120
+12 ;;SDEC07 Error: Invalid appointment request type.^Invalid appointment request type
+13 ;;THAT TIME IS NOT WITHIN SCHEDULED PERIOD^That time not within scheduled period
+14 ;;SDEC07 Error: Invalid clinic ID.^Invalid clinic ID
+15 ;;is an inactive clinic.^Clinic is inactive
+16 ;;Another user is working with this patient's record. Please try again later^Patient record locked
+17 ;;SDEC07 Error: Unable to add appointment to SDEC APPOINTMENT file.^Can't add appointment to SDEC APPOINTMENT file
+18 ;;Invalid Clinic ID - Cannot determine if Overbook is allowed.^Cannot determine if Overbook is allowed.
+19 ;;Invalid Appointment Date.^Invalid Appointment Date.
+20 ;;SDEC08: Invalid Appointment ID^Invalid Appointment ID
+21 ;;Error adding date to file 44: Clinic^Error adding date to file 44
+22 ;;SDEC08: Invalid status type^Invalid status type
+23 ;;Another user is working with this patient's record. Please try again later^Patient record locked
+24 ;;Invalid Appointment ID.^Invalid Appointment ID
+25 ;;Appointment is not Cancelled.^Appointment is not Cancelled
+26 ;;Cancelled by patient appointment cannot be uncancelled.^Cannot be uncancelled
+27 ;;FileMan add toS DPT error: Patient=^FileMan add toS DPT error
+28 ;;Another user is working with this patient's record. Please try again later^Patient record locked
+29 ;;
+30 ;
ACK ;****BUILD THE RESPONSE MSA (Cont. of SDHL7APT)
+1 ; move to this tag from sdhl7apt
SET ERRTXT=$$ERRLKP^SDHL7APU(ERRTXT)
+2 SET ERRTXT=$$STRIP^SDHL7APU(ERRTXT)
+3 ;
+4 KILL @MSGROOT
+5 NEW HLA,ERR,LEN,FOUNDCN
+6 DO INIT^HLFNC2(EIN,.HL)
+7 SET HL("FS")="|"
SET HL("ECH")="^~\&"
+8 SET (ERR,FOUNDCN)=0
+9 SET HL("MID")=$SELECT($GET(HL("MID")):HL("MID"),1:ACKMSG)
+10 ;879 incr to 99
SET HLA("HLA",1)="MSA"_HL("FS")_$SELECT(ERRCND:"AE",1:"AA")_HL("FS")_HL("MID")_HL("FS")_$SELECT(ERRCND:$EXTRACT(ERRTXT,1,99),1:"")_HL("FS")
+11 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.MYRESULT)
+12 QUIT
