SDHLAPT2 ;MS/PB - VISTA SCHEDULING RPCS ;Nov 14, 2014
;;5.3;Scheduling;**704,773,810**;Nov 14, 2018;Build 3
;
Q
AIL ;
D PARSESEG^SDHL7APU(SEG,.AIL,.HL)
S SDCL=+$G(AIL(3,1,1)) N RET,RET1 D RESLKUP^SDHL7APU(SDCL) S SDECRES=RET1
N STCREC,CONSID,MTC
S STCREC=""
S SDAPTYP=""
S (SDPARENT)=$G(AIL(1,4,1,4))
I $G(AIL(1,4,1,2))="C" S CONSID=$G(AIL(1,4,1,1)),SDAPTYP="C|"_$G(AIL(1,4,1,1))
I $G(AIL(1,4,1,2))="R" D
. S MTC=$P($G(^SDEC(409.85,+$G(SDPARENT),3)),"^"),SDMRTC=$S(MTC>0:1,1:0)
. ;get the last child sequence number and set RTCID and MSGARY("RTCID") = to last sequence number plus 1
. K X12,RTCID S RTCID="",X12=0 I +$L(SDPARENT) F S X12=$O(^SDEC(409.85,SDPARENT,2,X12)) Q:X12'>0 S RTCID=X12+1
. S:$G(MTC)=1 SDAPTYP="R|"_$G(RTCID) ; if this is a multi RTC order $P(SDAPTYP,"|",2) is the next child sequence number, else it is null
. Q
;Get parent rtc order if it is a multi appointment rtc
S:$G(AIL(1,4,1,2))="A" SDAPTYP="A|"
I $P(PROVAPT(XX+1),"|")="NTE" S SDECNOTE=$P($G(PROVAPT(XX+1)),"|",4)
Q
;
NEWTIME ;Adjust time for intrafacility appointment
N ST1,ST12
S ST12=$P(SDTMPHL(1),"|",12),ST1=$P(ST12,"^",4)
S INST=$$INST^SDTMPHLA(AIL(2,3,1,1))
S ST1=$$JSONTFM(ST1,INST)
S ST1=$$FMADD^XLFDT(ST1,,,5) ;Add 5 minutes
S ST1=$$TMCONV^SDTMPHLA(ST1,INST)
S $P(ST12,"^",4)=$G(ST1)
S $P(SDTMPHL(1),"|",12)=$G(ST12)
S $P(SDTMPHL(5),"|",5)=$P(ST12,"^",4)
Q
;
CHKCON(DFN,SDAPTYP) ; checks if both consult ids or both rtc ids match the patient, if the consult or rts is not for the patient, reject
Q:$G(AIL(1,3,1,4))'=$G(AIL(2,3,1,4))
S STOPME=0
N IENS,X1,GMRDFN
I $P($G(SDAPTYP),"|",1)="C" D
.F X1=1:1:2 D
..Q:$G(STOPME)=1
..S IENS=+$G(AIL(X1,4,1,1))
..Q:+$G(IENS)'>0
..S GMRDFN=$$GET1^DIQ(123,IENS_",",.02,"I","ERR")
..I $G(GMRDFN)'=$G(DFN)!($G(^GMR(123,+$G(IENS),0))="") D
...S ERR="MSA^1^^100^AE^CONSULT ID# "_+$G(IENS)_" IS NOT FOR PATIENT "_$P(^DPT(DFN,0),"^")
...D SENDERR^SDHL7APU(ERR)
...S STOPME=1
..Q
.Q
I $P($G(SDAPTYP),"|",1)="R" D
.F X1=1:1:2 D
..Q:$G(STOPME)=1
..S IENS=+$G(AIL(X1,4,1,1))
..Q:+$G(IENS)'>0
..I $G(DFN)'=$P($G(^SDEC(409.85,IENS,0)),"^",1)!($G(^SDEC(409.85,IENS,0))="") D
...S STOPME=1
...S ERR="MSA^1^^100^AE^RTC ORDER# "_+$P($G(SDAPTYP),"|",2)_" IS NOT FOR PATIENT "_$P(^DPT(DFN,0),"^")
...D SENDERR^SDHL7APU(ERR)
..Q
Q
;
CHKCAN(PAT,CLINIC,DATE) ; check to see if the appointment in 44 is canceled correctly. if not cancel it
N TIEN,DIK,DA
Q:$G(PAT)'>0
Q:$G(CLINIC)'>0
Q:$G(DATE)=""
S TIEN=$$SCIEN^SDECU2(PAT,CLINIC,DATE)
Q:$G(TIEN)'>0
I $G(TIEN)>0 D
.S DIK="^SC("_CLINIC_",""S"","_DATE_",1,"
.S DA(2)=CLINIC,DA(1)=DATE,DA=TIEN
.D ^DIK
.K DIK,DA
Q
;
JSONTFM(DTTM,INST) ;Convert XML/JSON external time to FM format in local timezone. If zulu time, apply timezone difference.
;Inputs:
; DTTM = Date with time in JSON format
; INST = Institution
;Output:
; Date and time in FileMan format with zulu difference applied if indicated
N DIFF,DATE,TM,SDT,ZULU,TZINST
S ZULU=DTTM["Z" ;is this zulu time?
S TZINST=$$CHKINST^SDTMPHLA(INST) ;get correct institution
S DATE=$P(DTTM,"T"),DATE=$TR(DATE,"-",""),DATE=DATE-17000000 ;get date
S TM=$P(DTTM,"T",2),TM=$P(TM,"."),TM=$TR(TM,":",""),TM=+("."_TM) ;get time
I TM=0 S TM=".000001" ;Add 1 second to avoid midnight problem
S DIFF=0 I ZULU S DIFF=$P($$UTC^DIUTC(DATE_TM,,TZINST,,1),"^",3) ;if zulu compute tz difference
S SDT=$$FMADD^XLFDT(DATE_TM,,$G(DIFF),0) ;add tz difference
Q +$E(SDT,1,13) ;get rid of 1 second and trailing zeroes
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDHLAPT2 3576 printed Apr 09, 2024@21:40:48 Page 2
SDHLAPT2 ;MS/PB - VISTA SCHEDULING RPCS ;Nov 14, 2014
+1 ;;5.3;Scheduling;**704,773,810**;Nov 14, 2018;Build 3
+2 ;
+3 QUIT
AIL ;
+1 DO PARSESEG^SDHL7APU(SEG,.AIL,.HL)
+2 SET SDCL=+$GET(AIL(3,1,1))
NEW RET,RET1
DO RESLKUP^SDHL7APU(SDCL)
SET SDECRES=RET1
+3 NEW STCREC,CONSID,MTC
+4 SET STCREC=""
+5 SET SDAPTYP=""
+6 SET (SDPARENT)=$GET(AIL(1,4,1,4))
+7 IF $GET(AIL(1,4,1,2))="C"
SET CONSID=$GET(AIL(1,4,1,1))
SET SDAPTYP="C|"_$GET(AIL(1,4,1,1))
+8 IF $GET(AIL(1,4,1,2))="R"
Begin DoDot:1
+9 SET MTC=$PIECE($GET(^SDEC(409.85,+$GET(SDPARENT),3)),"^")
SET SDMRTC=$SELECT(MTC>0:1,1:0)
+10 ;get the last child sequence number and set RTCID and MSGARY("RTCID") = to last sequence number plus 1
+11 KILL X12,RTCID
SET RTCID=""
SET X12=0
IF +$LENGTH(SDPARENT)
FOR
SET X12=$ORDER(^SDEC(409.85,SDPARENT,2,X12))
if X12'>0
QUIT
SET RTCID=X12+1
+12 ; if this is a multi RTC order $P(SDAPTYP,"|",2) is the next child sequence number, else it is null
if $GET(MTC)=1
SET SDAPTYP="R|"_$GET(RTCID)
+13 QUIT
End DoDot:1
+14 ;Get parent rtc order if it is a multi appointment rtc
+15 if $GET(AIL(1,4,1,2))="A"
SET SDAPTYP="A|"
+16 IF $PIECE(PROVAPT(XX+1),"|")="NTE"
SET SDECNOTE=$PIECE($GET(PROVAPT(XX+1)),"|",4)
+17 QUIT
+18 ;
NEWTIME ;Adjust time for intrafacility appointment
+1 NEW ST1,ST12
+2 SET ST12=$PIECE(SDTMPHL(1),"|",12)
SET ST1=$PIECE(ST12,"^",4)
+3 SET INST=$$INST^SDTMPHLA(AIL(2,3,1,1))
+4 SET ST1=$$JSONTFM(ST1,INST)
+5 ;Add 5 minutes
SET ST1=$$FMADD^XLFDT(ST1,,,5)
+6 SET ST1=$$TMCONV^SDTMPHLA(ST1,INST)
+7 SET $PIECE(ST12,"^",4)=$GET(ST1)
+8 SET $PIECE(SDTMPHL(1),"|",12)=$GET(ST12)
+9 SET $PIECE(SDTMPHL(5),"|",5)=$PIECE(ST12,"^",4)
+10 QUIT
+11 ;
CHKCON(DFN,SDAPTYP) ; checks if both consult ids or both rtc ids match the patient, if the consult or rts is not for the patient, reject
+1 if $GET(AIL(1,3,1,4))'=$GET(AIL(2,3,1,4))
QUIT
+2 SET STOPME=0
+3 NEW IENS,X1,GMRDFN
+4 IF $PIECE($GET(SDAPTYP),"|",1)="C"
Begin DoDot:1
+5 FOR X1=1:1:2
Begin DoDot:2
+6 if $GET(STOPME)=1
QUIT
+7 SET IENS=+$GET(AIL(X1,4,1,1))
+8 if +$GET(IENS)'>0
QUIT
+9 SET GMRDFN=$$GET1^DIQ(123,IENS_",",.02,"I","ERR")
+10 IF $GET(GMRDFN)'=$GET(DFN)!($GET(^GMR(123,+$GET(IENS),0))="")
Begin DoDot:3
+11 SET ERR="MSA^1^^100^AE^CONSULT ID# "_+$GET(IENS)_" IS NOT FOR PATIENT "_$PIECE(^DPT(DFN,0),"^")
+12 DO SENDERR^SDHL7APU(ERR)
+13 SET STOPME=1
End DoDot:3
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
+16 IF $PIECE($GET(SDAPTYP),"|",1)="R"
Begin DoDot:1
+17 FOR X1=1:1:2
Begin DoDot:2
+18 if $GET(STOPME)=1
QUIT
+19 SET IENS=+$GET(AIL(X1,4,1,1))
+20 if +$GET(IENS)'>0
QUIT
+21 IF $GET(DFN)'=$PIECE($GET(^SDEC(409.85,IENS,0)),"^",1)!($GET(^SDEC(409.85,IENS,0))="")
Begin DoDot:3
+22 SET STOPME=1
+23 SET ERR="MSA^1^^100^AE^RTC ORDER# "_+$PIECE($GET(SDAPTYP),"|",2)_" IS NOT FOR PATIENT "_$PIECE(^DPT(DFN,0),"^")
+24 DO SENDERR^SDHL7APU(ERR)
End DoDot:3
+25 QUIT
End DoDot:2
End DoDot:1
+26 QUIT
+27 ;
CHKCAN(PAT,CLINIC,DATE) ; check to see if the appointment in 44 is canceled correctly. if not cancel it
+1 NEW TIEN,DIK,DA
+2 if $GET(PAT)'>0
QUIT
+3 if $GET(CLINIC)'>0
QUIT
+4 if $GET(DATE)=""
QUIT
+5 SET TIEN=$$SCIEN^SDECU2(PAT,CLINIC,DATE)
+6 if $GET(TIEN)'>0
QUIT
+7 IF $GET(TIEN)>0
Begin DoDot:1
+8 SET DIK="^SC("_CLINIC_",""S"","_DATE_",1,"
+9 SET DA(2)=CLINIC
SET DA(1)=DATE
SET DA=TIEN
+10 DO ^DIK
+11 KILL DIK,DA
End DoDot:1
+12 QUIT
+13 ;
JSONTFM(DTTM,INST) ;Convert XML/JSON external time to FM format in local timezone. If zulu time, apply timezone difference.
+1 ;Inputs:
+2 ; DTTM = Date with time in JSON format
+3 ; INST = Institution
+4 ;Output:
+5 ; Date and time in FileMan format with zulu difference applied if indicated
+6 NEW DIFF,DATE,TM,SDT,ZULU,TZINST
+7 ;is this zulu time?
SET ZULU=DTTM["Z"
+8 ;get correct institution
SET TZINST=$$CHKINST^SDTMPHLA(INST)
+9 ;get date
SET DATE=$PIECE(DTTM,"T")
SET DATE=$TRANSLATE(DATE,"-","")
SET DATE=DATE-17000000
+10 ;get time
SET TM=$PIECE(DTTM,"T",2)
SET TM=$PIECE(TM,".")
SET TM=$TRANSLATE(TM,":","")
SET TM=+("."_TM)
+11 ;Add 1 second to avoid midnight problem
IF TM=0
SET TM=".000001"
+12 ;if zulu compute tz difference
SET DIFF=0
IF ZULU
SET DIFF=$PIECE($$UTC^DIUTC(DATE_TM,,TZINST,,1),"^",3)
+13 ;add tz difference
SET SDT=$$FMADD^XLFDT(DATE_TM,,$GET(DIFF),0)
+14 ;get rid of 1 second and trailing zeroes
QUIT +$EXTRACT(SDT,1,13)
