SDHL7APU ;MS/TG,PH - TMP HL7 Routine;OCT 16, 2018
;;5.3;Scheduling;**704,714,773,780,798,810,859**;AUG 17, 2018;Build 10
;
; 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))
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
;
CHKCHILD ;
N MTC,FIRST
K RTCCLIN
I $P($G(SDAPTYP),"|",1)="R" D ; if rtc check to see if the child is actually a parent
.I $G(SDPARENT)="" S:$G(SCH(24,1,1))'="" SDPARENT=$G(SCH(24,1,1))
.I $G(SDPARENT)="" S:$G(SCH(23,1,1))'="" SDPARENT=$G(SCH(23,1,1))
.S:$G(SDPARENT)>0 MTC=$P($G(^SDEC(409.85,+$G(SDPARENT),3)),"^",3),SDMRTC=$S(MTC>0:"1",1:0)
.Q:+$G(MTC)=0 ; Not a multi RTC
.S:$G(SDCL)>0 RTCCLIN=$P(^SDEC(409.85,$G(SDPARENT),0),"^",9)
.S DUZ=$G(MSGARY("DUZ"))
.Q:$G(RTCCLIN)'=SDCL
.N X12,X13 S (X12,X13)=0 F S X12=$O(^SDEC(409.85,$G(SDPARENT),2,X12)) Q:X12'>0 S X13=X12
.Q:$G(X13)=MTC!($G(X13)>MTC)
.I $G(MTC)>0 F I=1:1:MTC Q:I>MTC D
..S:$G(INP(3))="" INP(3)=DT S INP(25)=SDPARENT,INP(6)=$P(^SDEC(409.85,SDPARENT,0),"^",9),RTN=0
..S INP(5)="RTC",INP(1)="",INP(14)="YES",INP(15)=$P($G(^SDEC(409.85,SDPARENT,3)),"^",2),INP(16)=I
..D ARSET^SDHLAPT1(.RTN,.INP)
..I I=1 S:$P($G(RTN),"^",2)>0 FCHILD=$P(RTN,"^",2)
.Q
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
; Need to add code to add the rtcparent to the HL7 message and to parse it out.
N NODE3,INTV,NUMAPT,ORDATE,SDCHILD,SDPARENT
K INP
S:$G(MSGARY("PROVIEN"))>0 INP(10)=$$GET1^DIQ(200,$G(MSGARY("PROVIEN"))_",",.01,"E")
;
S SDPARENT=$G(SCH(24,1,1))
S PCE="" S PCE=$P($G(^DPT($G(DFN),"ENR")),U,1) I PCE'="" D
.S INP(13)=$$GET1^DIQ(27.11,PCE,.07,"E")
S:$G(SDMRTC)'="" INP(14)=$S(SDMRTC=1:"YES",SDMRTC=0:"NO",1:"")
;I $G(SDPARENT)'="" S SDPARENT=$G(MSGARY("SDPARENT"))
I +$G(SDPARENT)>0 S NODE3=$G(^SDEC(409.85,+SDPARENT,3)),INTV=$P(NODE3,"^",2)
S INP(1)=$P(SDAPTYP,"|",2) ;If a new RTC order 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)="APPT"
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 INP(9)=$S(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 INP(14)=""
S:$G(SDMRTC)'="" INP(14)=$S(SDMRTC=1:"YES",SDMRTC=0:"NO",1:"NO") ; SDMRTC=1:YES
S INP(15)=$G(INTV) ;If MRTC, the interval in days between appointments
S INP(16)=$G(AIL(1,4,1,4)) ;If MRTC, the appointment number for this appointment
S INP(17)="" ;null for TMP
N SCXX S SCXX=$S($G(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"
S:$G(SDCHILD)=$G(SDPARENT) SDPARENT=""
S INP(25)=$G(SDPARENT)
S:$G(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
N HLA
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDHL7APU 17071 printed Apr 09, 2024@21:47:14 Page 2
SDHL7APU ;MS/TG,PH - TMP HL7 Routine;OCT 16, 2018
+1 ;;5.3;Scheduling;**704,714,773,780,798,810,859**;AUG 17, 2018;Build 10
+2 ;
+3 ; Integration Agreements:
+4 ;
+5 QUIT
+6 ;
+7 ;Helper routine to process SIU^S12 messages from the "TMP VISTA" Subscriber protocol
+8 ;
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
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 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 ;
+33 QUIT
SCHNTE(SCHNTE,INP,MSGARY) ;
+1 ;
+2 SET SDECNOTE=$GET(SCHNTE(3))
+3 IF $GET(MSGARY("EVENT"))="CANCELED"
SET SDECNOT=$GET(SCHNTE(3))
+4 QUIT
PID(PID,INP,MSGARY) ;
+1 ;
+2 SET MSGARY("MPI")=$GET(PID(3,1,1))
+3 SET DFN=$$GETDFN^MPIF001(MSGARY("MPI"))
+4 QUIT
+5 ;
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 ;
+2 if $DATA(AIL)
SET AIL(CNT,1)=1
+3 NEW STCREC
+4 SET STCREC=""
+5 SET INP(6)=$GET(AIL(1,3,1,1))
+6 SET (SDCL)=$GET(AIL(1,3,1,1))
+7 if $GET(AIL(2,3,1,1))'=""
SET SDCL2=$GET(AIL(2,3,1,1))
+8 if $GET(SDCL2)=$GET(SDCL)
SET SDCL3=1
+9 SET INP(4)=$$NAME^XUAF4(+$GET(AIL(1,3,1,4)))
+10 ;CLINIC STOP CODE
+11 DO GETSTC^SDECCON(.STCREC,$PIECE($GET(SDCL),U,1))
+12 IF $GET(AIL(1,4,1,2))="C"
Begin DoDot:1
+13 NEW XSDDDT,GMRDA
+14 SET GMRDA=$GET(AIL(1,4,1,1))
if $$LOW^XLFSTR($GET(GMRDA))="undefined"
SET GMRDA=""
+15 SET XSDDDT=$$GET1^DIQ(123,$GET(GMRDA)_",",17,"I")
SET SDDDT=$$FMTE^XLFDT(XSDDDT)
+16 SET SDAPTYP="C|"_$GET(GMRDA)
+17 ;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
+18 if $GET(AIL(1,3,1,4))=$GET(AIL(2,3,1,4))
SET INTRA=1
+19 IF $GET(AIL(1,4,1,2))="A"
SET SDAPTYP="A|"
+20 IF $GET(AIL(1,4,1,2))="R"
SET SDAPTYP="R|"_$GET(AIL(1,4,1,4))
+21 QUIT
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 ;
CHKCHILD ;
+1 NEW MTC,FIRST
+2 KILL RTCCLIN
+3 ; if rtc check to see if the child is actually a parent
IF $PIECE($GET(SDAPTYP),"|",1)="R"
Begin DoDot:1
+4 IF $GET(SDPARENT)=""
if $GET(SCH(24,1,1))'=""
SET SDPARENT=$GET(SCH(24,1,1))
+5 IF $GET(SDPARENT)=""
if $GET(SCH(23,1,1))'=""
SET SDPARENT=$GET(SCH(23,1,1))
+6 if $GET(SDPARENT)>0
SET MTC=$PIECE($GET(^SDEC(409.85,+$GET(SDPARENT),3)),"^",3)
SET SDMRTC=$SELECT(MTC>0:"1",1:0)
+7 ; Not a multi RTC
if +$GET(MTC)=0
QUIT
+8 if $GET(SDCL)>0
SET RTCCLIN=$PIECE(^SDEC(409.85,$GET(SDPARENT),0),"^",9)
+9 SET DUZ=$GET(MSGARY("DUZ"))
+10 if $GET(RTCCLIN)'=SDCL
QUIT
+11 NEW X12,X13
SET (X12,X13)=0
FOR
SET X12=$ORDER(^SDEC(409.85,$GET(SDPARENT),2,X12))
if X12'>0
QUIT
SET X13=X12
+12 if $GET(X13)=MTC!($GET(X13)>MTC)
QUIT
+13 IF $GET(MTC)>0
FOR I=1:1:MTC
if I>MTC
QUIT
Begin DoDot:2
+14 if $GET(INP(3))=""
SET INP(3)=DT
SET INP(25)=SDPARENT
SET INP(6)=$PIECE(^SDEC(409.85,SDPARENT,0),"^",9)
SET RTN=0
+15 SET INP(5)="RTC"
SET INP(1)=""
SET INP(14)="YES"
SET INP(15)=$PIECE($GET(^SDEC(409.85,SDPARENT,3)),"^",2)
SET INP(16)=I
+16 DO ARSET^SDHLAPT1(.RTN,.INP)
+17 IF I=1
if $PIECE($GET(RTN),"^",2)>0
SET FCHILD=$PIECE(RTN,"^",2)
End DoDot:2
+18 QUIT
End DoDot:1
+19 QUIT
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 ; Need to add code to add the rtcparent to the HL7 message and to parse it out.
+2 NEW NODE3,INTV,NUMAPT,ORDATE,SDCHILD,SDPARENT
+3 KILL INP
+4 if $GET(MSGARY("PROVIEN"))>0
SET INP(10)=$$GET1^DIQ(200,$GET(MSGARY("PROVIEN"))_",",.01,"E")
+5 ;
+6 SET SDPARENT=$GET(SCH(24,1,1))
+7 SET PCE=""
SET PCE=$PIECE($GET(^DPT($GET(DFN),"ENR")),U,1)
IF PCE'=""
Begin DoDot:1
+8 SET INP(13)=$$GET1^DIQ(27.11,PCE,.07,"E")
End DoDot:1
+9 if $GET(SDMRTC)'=""
SET INP(14)=$SELECT(SDMRTC=1:"YES",SDMRTC=0:"NO",1:"")
+10 ;I $G(SDPARENT)'="" S SDPARENT=$G(MSGARY("SDPARENT"))
+11 IF +$GET(SDPARENT)>0
SET NODE3=$GET(^SDEC(409.85,+SDPARENT,3))
SET INTV=$PIECE(NODE3,"^",2)
+12 ;If a new RTC order 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)
+13 SET INP(2)=$GET(DFN)
+14 DO NOW^%DTC
SET NOW=$$HTFM^XLFDT($HOROLOG)
SET INP(3)=$$FMTE^XLFDT(NOW)
+15 ;NEEDS THE TEXT INSTITUTION NAME
+16 ;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)))
+17 SET INP(5)="APPT"
+18 SET INP(6)=$GET(SDCL)
+19 ;null for TMP appointments or can we get this from the original RTC order?
SET INP(7)=""
+20 SET INP(8)="FUTURE"
+21 NEW X11
SET X11=$PIECE($GET(SDAPTYP),"|")
if $GET(X11)=""
SET X11="A"
+22 ;request by provider or patient. RTC orders and consults will always be PROVIDER otherwise it is PATIENT
SET INP(9)=$SELECT(X11="A":"PATIENT",1:"PROVIDER")
+23 ;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")
+24 SET SDDDT=$GET(SCH(5,1,2))
+25 if $GET(SDDDT)=""
SET SDDDT=$GET(SCH(11,1,8))
+26 ; 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)
+27 SET INP(11)=$GET(SDDDT)
+28 ; RTC comments these are different than the comments that are stored in in file 44 appointment multiple.
SET INP(12)=$GET(SDECNOTE)
+29 SET PCE=""
SET PCE=$PIECE($GET(^DPT(DFN,"ENR")),U,1)
IF PCE'=""
Begin DoDot:1
+30 SET INP(13)=$$GET1^DIQ(27.11,PCE,.07,"E")
End DoDot:1
+31 SET INP(14)=""
+32 ; SDMRTC=1:YES
if $GET(SDMRTC)'=""
SET INP(14)=$SELECT(SDMRTC=1:"YES",SDMRTC=0:"NO",1:"NO")
+33 ;If MRTC, the interval in days between appointments
SET INP(15)=$GET(INTV)
+34 ;If MRTC, the appointment number for this appointment
SET INP(16)=$GET(AIL(1,4,1,4))
+35 ;null for TMP
SET INP(17)=""
+36 NEW SCXX
SET SCXX=$SELECT($GET(SDPARENT)>0:$$GET1^DIQ(409.85,SDPARENT_",",15,"I"),1:0)
+37 ;is this service connected? we can get this from the parent
SET INP(18)=$SELECT($GET(SCXX)=1:"YES",1:"NO")
+38 SET SCPERC=0
+39 SET SCPERC=$PIECE(^DPT($GET(INP(2)),.3),"^",2)
+40 SET INP(19)=SCPERC
+41 SET INP(22)="9"
+42 SET INP(23)="NEW"
+43 if $GET(SDCHILD)=$GET(SDPARENT)
SET SDPARENT=""
+44 SET INP(25)=$GET(SDPARENT)
+45 ; this is the CPRS order number
if $GET(SDPARENT)>0
SET INP(28)=$PIECE($GET(^SDEC(409.85,+SDPARENT,7)),U,1)
+46 if $GET(INP(28))>0
SET INP(26)=$PIECE($GET(^SDEC(409.85,+SDPARENT,7)),U,2)
+47 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 NEW HLA
+3 DO INIT^HLFNC2(EIN,.HL)
+4 SET HL("FS")="|"
SET HL("ECH")="^~\&"
+5 SET CNT=1
SET @MSGROOT@(CNT)=$$MSA^SDTMBUS($GET(HL("MID")),ERR,.HL)
SET LEN=$LENGTH(@MSGROOT@(CNT))
+6 FOR IX=1:1:CNT
SET HLA("HLS",IX)=$GET(@MSGROOT@(IX))
+7 MERGE HLA("HLA")=HLA("HLS")
+8 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.MYRESULT)
+9 KILL @MSGROOT
+10 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)
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
