SDECUTL ;ALB/MGD - VISTA SCHEDULING RPCS ;Jul 02, 2021@16:42
;;5.3;Scheduling;**627,658,665,790**;Aug 13, 1993;Build 11
;
; Reference to ^GMR(123 is supported by IA #4837
Q
;
SYSSTAT(SDECY) ; SYSTEM STATUS
;SYSSTAT(SDECY) external parameter tag in SDEC
N SDECCNT,SDECD,SDECH,SDECII,SDECROW,SDECROW1,SDECYA
S SDECII=0
S SDECY=$NA(^TMP("SDEC",$J)) K @SDECY
;S SDECYA=$NA(^SDECTMPA($J)) K @SDECYA
S @SDECY@(SDECII)="T00080ERROR_ID^T00080ERROR_TEXT"_$C(30)
S SDECII=SDECII+1 S @SDECY@(SDECII)=$C(30,31)
Q
;
STRIP(SDECSTR) ;
; SDECSTR = input string to parse
N SDECDN,SDECI,SDECPC,SDECPCNT,SDECPDN,SDECRET
Q:$E(SDECSTR,1,8)=" " ""
S SDECI=""
S SDECRET=""
S SDECPCNT=""
S SDECDN=""
F Q:SDECDN D
. S SDECI=SDECI+1
. Q:$E(SDECSTR,SDECI)=" "
. S SDECPCNT=SDECPCNT+1
. S SDECPC=""
. S SDECPDN=""
. F Q:SDECPDN D
. . S SDECPC=SDECPC_$E(SDECSTR,SDECI)
. . S SDECI=SDECI+1
. . I ($E(SDECSTR,SDECI)=" ")!(SDECI>$L(SDECSTR)) S SDECPDN=1
. ;
. S SDECRET=$S(SDECPCNT'=1:SDECRET_U,1:"")_$S(SDECPCNT=4:$E(SDECPC,1,8),1:SDECPC)
. I (SDECPCNT=4)!(SDECI>$L(SDECSTR)) S SDECDN=1
;
Q SDECRET
;
FL(SDECSTR,SDECW,SDECD) ;EP
;format line
; SDECSTR = Text String to be formatted
; SDECW = Maximum width of text line
; SDECD = Delimiter; defaults to double pipe "||" to be used as the line separator
;
;RETURNS string delimited by double pipe "||" to be used as line separator
N SDECOUT,SDECPTR,SDECTMP
I $G(SDECW)="" S SDECW=80
I '+SDECW S SDECW=80
I $L(SDECSTR)'>SDECW Q SDECSTR
I $G(SDECD)="" S SDECD="||"
S SDECOUT=""
S SDECPTR=SDECW
;handle no spaces in the string
I SDECSTR'[" " D
. F Q:SDECSTR="" D
. . I $L(SDECSTR)'>SDECW D
. . . S SDECOUT=$S(SDECOUT'="":SDECOUT_SDECD,1:"")_SDECSTR
. . . S SDECSTR=""
. . I $L(SDECSTR)>SDECW D
. . . S SDECOUT=$S(SDECOUT'="":SDECOUT_SDECD,1:"")_$E(SDECSTR,1,SDECW)
. . . S SDECSTR=$E(SDECSTR,SDECW+1,$L(SDECSTR))
;string does contain a space
I SDECSTR[" " D
. F Q:SDECSTR="" D
. . I $L(SDECSTR)'>SDECW D
. . . S SDECOUT=$S(SDECOUT'="":SDECOUT_SDECD,1:"")_SDECSTR
. . . S SDECSTR=""
. . I $L(SDECSTR)>SDECW D
. . . F Q:$E(SDECSTR,SDECPTR)=" " D
. . . . S SDECPTR=SDECPTR-1
. . . S SDECOUT=$S(SDECOUT'="":SDECOUT_SDECD,1:"")_$E(SDECSTR,1,SDECPTR-1)
. . . S SDECSTR=$E(SDECSTR,SDECPTR+1,$L(SDECSTR))
. . . S SDECPTR=SDECW
Q SDECOUT
;
; Check and validate visit
CHKVISIT(VIEN,DFN,CAT) ;EP
N RET,X0
S RET=$$ISLOCKED(VIEN)
Q:RET $S(RET<0:$$ERR^SDEC44("Visit "_VIEN_" not found."),1:$$ERR^SDEC44("Visit "_VIEN_" is locked."))
S X0=$G(^AUPNVSIT(VIEN,0))
I $G(DFN),$P(X0,U,5)'=DFN S RET=$$ERR^SDEC44("Visit "_VIEN_" does not belong to Patient "_DFN_".")
E I $P(X0,U,11) S RET=$$ERR^SDEC44("Visit "_VIEN_" has been deleted.")
E I $L($G(CAT)),CAT'[$P(X0,U,7) S RET=$$ERR^SDEC44("Service Category of Visit "_VIEN_" is not "_CAT_".",$$EXTERNAL^DILFD(9000010,.07,,$P(X0,U,7)))
Q RET
;
; Returns visit lock status:
; -1: Visit not found
; 0: Visit is not locked
; 1: Visit is locked
ISLOCKED(IEN) ;PEP - Is visit locked?
N DAT,DAYS,EXPDT
S DAT=$$VISREFDT(IEN)
Q:'DAT -1
;IHS/MSC/PLS - 02/18/09 - Parameter now holds lock expiration date
;S EXPDT=$$GET^XPAR("USR","BEHOENCX VISIT LOCK OVERRIDE","`"_IEN)
;Q:EXPDT'<$$DT^XLFDT() 0
;D:EXPDT DEL^XPAR("USR","BEHOENCX VISIT LOCK OVERRIDE","`"_IEN) ; remove expired locked
;Q:$$GET^XPAR("USR","BEHOENCX VISIT LOCK OVERRIDE","`"_IEN) 0
;S DAYS=$$GET^XPAR("ALL","BEHOENCX VISIT LOCKED")
Q $$FMDIFF^XLFDT(DT,DAT)>1 ;$S(DAYS<1:1,1:DAYS)
; Returns reference date for visit lock check
VISREFDT(IEN) ;
N ADM,DIS,DAT
S DAT=$P($G(^AUPNVSIT(+IEN,0)),U,2)
Q:'DAT ""
S ADM=$O(^DGPM("AVISIT",IEN,0))
Q:'ADM DAT
S DIS=$P($G(^DGPM(ADM,0)),U,17)
Q $S(DIS:$P($G(^DGPM(DIS,0)),U),1:DT)
;
; Add/edit a file entry
UPDATE(FDA,FLG,IEN) ;EP
N ERR,DFN,X
I $G(FLG)["@" S FLG=$TR(FLG,"@")
E D
.S X="FDA"
.F S X=$Q(@X) Q:'$L(X) K:'$L(@X) @X
Q:$D(FDA)'>1 ""
D UPDATE^DIE(.FLG,"FDA","IEN","ERR")
K FDA
Q $S($G(ERR("DIERR",1)):-ERR("DIERR",1)_U_ERR("DIERR",1,"TEXT",1),1:"")
;
ISACTIVE(ADT,IDT,CDT) ;is CDT an active date given an active date and inactive date
;INPUT:
; ADT = Activation date in FM format
; IDT = Inactivation date in FM format
; CDT = date to check - default to 'today'
;RETURN:
; 0=inactive
; 1=active
; 2=ADT & IDT null; calling routine can decide if default to active or inactive
; 3=date to check is before both activation and inactivation; calling routine can decide if default to active or inactive
N RET
S RET=""
S ADT=$S($P($G(ADT),".",1)?7N:$P(ADT,".",1),1:"")
S IDT=$S($P($G(IDT),".",1)?7N:$P(IDT,".",1),1:"")
S CDT=$S($P($G(CDT),".",1)?7N:$P(CDT,".",1),1:$P($$NOW^XLFDT,".",1))
;0 0
I ADT="",IDT="" S RET=2
Q:RET'="" RET
;1 0
I ADT'="",IDT="" D
.S RET=1 ;TODO: what if 'today' or CDT is before ADT
Q:RET'="" RET
;0 1
I ADT="",IDT'="" S RET=0 ;TODO: what if 'today' or CDT is before IDT
Q:RET'="" RET
;1 1
; active < T < inactive
I CDT'<ADT,CDT'>IDT S RET=1
Q:RET'="" RET
; active < inactive < T
I ADT<IDT,IDT<CDT S RET=0
Q:RET'="" RET
; inactive < T < active
I IDT<CDT,CDT<ADT S RET=0
Q:RET'="" RET
; inactive < active < T
I IDT<ADT,ADT<CDT S RET=1
Q:RET'="" RET
;T < active < inactive AND T < inactive < active
I RET="" S RET=3 ;should not get here
Q RET
;
APPTGET(DFN,SDBEG,SDCL,SDRES) ;get SDEC APPOINTMENT for given patient, time, and clinic
N SDAPPT,SDI,SDNOD,SDRCL,SDARES,SDBEGINDX,SDEND
S SDAPPT=""
S SDCL=$G(SDCL)
S SDRES=$G(SDRES)
; Reset SDBEG to immediately before actual start time
S SDBEGINDX=SDBEG-.00001
S SDEND=$E(SDBEG,1,7) ; Set stop date
; Utilize APTDT x-ref for speed. VSE-1172
F S SDBEGINDX=$O(^SDEC(409.84,"APTDT",DFN,SDBEGINDX)) Q:'SDBEGINDX!($P(SDBEGINDX,".",1)>SDEND) D Q:SDAPPT'=""
.S SDI=0 F S SDI=$O(^SDEC(409.84,"APTDT",DFN,SDBEGINDX,SDI)) Q:SDI'>0 D Q:SDAPPT'=""
..S SDNOD=$G(^SDEC(409.84,SDI,0))
..; Quit if this record has one of the Cancelled Statuses. VSE-1171
..Q:"^N^NA^C^CA^PC^PCA^"[(U_$P(SDNOD,U,17)_U)
..Q:SDBEG'=$P(SDNOD,U,1)
..I +SDRES Q:+SDRES'=$P(SDNOD,U,7)
..I 'SDRES S SDARES=$P(SDNOD,U,7) S SDRCL=$P($G(^SDEC(409.831,+SDARES,0)),U,4) Q:SDRCL'=SDCL
..S SDAPPT=SDI
Q SDAPPT
;
GETRES(SDCL,INACT) ;get resource for clinic - SDEC RESOURCE
N SDHLN,SDI,SDNOD,SDRES,SDRES1
S (SDRES,SDRES1)=""
S SDHLN=$P($G(^SC(SDCL,0)),U,1)
Q:SDHLN="" ""
S SDI="" F S SDI=$O(^SDEC(409.831,"ALOC",SDCL,SDI)) Q:SDI="" D Q:SDRES'=""
.S SDNOD=$G(^SDEC(409.831,SDI,0))
.I '$G(INACT) Q:$$GET1^DIQ(409.831,SDI_",",.02)="YES"
.S:SDRES1="" SDRES1=SDI
.Q:$P($P(SDNOD,U,11),";",2)'="SC("
.S SDRES=SDI
.;I $$UP^XLFSTR($P(SDNOD,U,1))=SDHLN S SDRES=SDI
I SDRES="",SDRES1'="" S SDRES=SDRES1
Q SDRES
;
RECALL(DFN,SDT,SDCL) ;is this appointment for RECALL
;INPUT:
; DFN = Patient ID pointer to PATIENT file 2
; SDT = Appointment date/time in fm format
N SDI,SDNOD1,SDRET
S SDRET=""
S SDI=0 F S SDI=$O(^SD(403.56,"B",DFN,SDI)) Q:SDI'>0 D Q:SDRET'=""
.S SDNOD1=$G(^SD(403.56,SDI,1))
.Q:$P(SDNOD1,U,1)'=SDT
.Q:$P(SDNOD1,U,2)'=SDCL
.S SDRET=SDI
Q SDRET
;
SDCL(SDAPID) ;get clinic for given SDEC APPOINTMENT id
;INPUT:
; SDAPID - appt ID pointer to SDEC APPOINTMENT file 409.84
;RETURN:
; Clinic ID pointer to HOSPITAL LOCATION file 44
N SDAPTYP,SDCL
S SDCL=""
S SDAPTYP=$$GET1^DIQ(409.84,SDAPID_",",.22,"I")
S:$P(SDAPTYP,"|",2)="SDWL(409.3," SDCL=$$GET1^DIQ(409.3,$P(SDAPTYP,"|",2)_",",13.2,"I")
S:$P(SDAPTYP,"|",1)="SD(403.5," SDCL=$$GET1^DIQ(403.5,$P(SDAPTYP,"|",2)_",",4.5,"I")
S:$P(SDAPTYP,"|",1)="GMR(123," SDCL=$$GET1^DIQ(123,$P(SDAPTYP,"|",2)_",",.04,"I") ;ICR 4837
Q SDCL
;
PTSEC(DFN) ;patient sensitive & record access checks; calls DG SENSITIVE RECORD ACCESS api
;INPUT:
; DFN - patient ID pointer to PATIENT file 2
;RETURN:
; RESULT - the following pipe pieces:
; 1. return code:
; -1-RPC/API failed
; Required variable not defined
; 0-No display/action required
; Not accessing own, employee, or sensitive record
; 1-Display warning message
; Sensitive and DG SENSITIVITY key holder
; or Employee and DG SECURITY OFFICER key holder
; 2-Display warning message/require OK to continue
; Sensitive and not a DG SENSITIVITY key holder
; Employee and not a DG SECURITY OFFICER key holder
; 3-Access to record denied
; Accessing own record
; 4-Access to Patient (#2) file records denied
; SSN not defined
; 2. display text/message
; 3. display text/message
; 4. display text/message
;
N SDI,SDLINE,SDRET,SDSEC,SDTXT
K SDRET,SDSEC
S SDRET=""
;D PTSEC^DGSEC4(.SDSEC,DFN,0) ;alb/sat 658
D PTSEC4(.SDSEC,DFN,0)
S $P(SDRET,"|",1)=SDSEC(1)
S:$G(SDSEC(2))'="" $P(SDRET,"|",2)=SDSEC(2) ;I DUZ=51 S:$G(SDSEC(2))'="" $P(SDRET,"|",2)=$$STRIP1(SDSEC(2))
S:$G(SDSEC(3))'="" $P(SDRET,"|",3)=SDSEC(3) ;I DUZ=51 S:$G(SDSEC(3))'="" $P(SDRET,"|",3)=$$STRIP1(SDSEC(3))
S SDTXT=""
S SDI=3 F S SDI=$O(SDSEC(SDI)) Q:SDI="" D
.S SDLINE=$$STRIP1(SDSEC(SDI))
.Q:SDLINE?." "
.S SDTXT=$S(SDTXT'="":SDTXT,1:"")_SDLINE
S:SDTXT'="" $P(SDRET,"|",4)=SDTXT
Q SDRET
PTSEC4(RESULT,DFN,DGMSG,DGOPT) ;RPC/API entry point for patient sensitive & record access checks ;alb/sat 658
;Output array (Required)
; RESULT(1)= -1-RPC/API failed
; Required variable not defined
; 0-No display/action required
; Not accessing own, employee, or sensitive record
; 1-Display warning message
; Sensitive and DG SENSITIVITY key holder
; or Employee and DG SECURITY OFFICER key holder
; 2-Display warning message/require OK to continue
; Sensitive and not a DG SENSITIVITY key holder
; Employee and not a DG SECURITY OFFICER key holder
; 3-Access to record denied
; Accessing own record
; 4-Access to Patient (#2) file records denied
; SSN not defined
; RESULT(2-10) = error or display messages
;
;Input parameters: DFN = Patient file entry (Required)
; DGMSG = If 1, generate message (optional)
; DGOPT = Option name^Menu text (Optional)
;
K RESULT
I $G(DFN)="" D Q
.S RESULT(1)=-1
.S RESULT(2)="Required variable missing."
S DGMSG=$G(DGMSG,0)
D OWNREC^DGSEC4(.RESULT,DFN,$G(DUZ),DGMSG)
I RESULT(1)=1 S RESULT(1)=3 Q
I RESULT(1)=2 S RESULT(1)=4 Q
K RESULT
D SENS^DGSEC4(.RESULT,DFN,$G(DUZ))
I RESULT(1)=1 D
.I $G(DUZ)="" D Q
..;DUZ must be defined to access sensitive record & update DG Security log
..S RESULT(1)=-1
..S RESULT(2)="Your user code is undefined. This must be defined to access a restricted patient record."
.;D SETLOG1^DGSEC(DFN,DUZ,,$G(DGOPT))
Q
;
STRIP1(SDTXT) ;strip out "*"
N SDI
S SDTXT=$TR(SDTXT,"*","")
F SDI=$L(SDTXT):-1:1 Q:$E(SDTXT,SDI)'=" " S SDTXT=$E(SDTXT,1,$L(SDTXT)-1)
Q SDTXT
;
WP(RET,STR,CH) ;Convert string STR to Word Processing array ;alb/sat 658
;INPUT:
; STR - String to convert
; CH - Max characters per line
;RETURN:
; RET - WP Array RET(<line cnt>,0)=<text>
N CH1,CNT,BEG,END,LCNT
K RET
Q:$G(STR)=""
I '+$G(CH) S CH=80
I $L(STR'>CH) S RET(1,0)=STR Q ;alb/sat 665
S (END,LCNT)=0
S BEG=1
F CNT=1:1:$L(STR) S CH1=$E(STR,CNT) D
.I CH1=" " S END=CNT
.I CNT'=BEG,'((CNT-BEG)#CH) D
..S LCNT=LCNT+1 S RET(LCNT,0)=$E(STR,BEG,$S(END'=0:END,1:CNT))
..S BEG=$S(END'=0:END,1:CNT)+1
..S END=0
I CNT'=BEG S LCNT=LCNT+1 S RET(LCNT,0)=$E(STR,BEG,$L(STR))
Q
WPSTR(ARR) ;convert WP field array to single string ;alb/sat 658
N RET,WPI
S RET=""
Q:'$D(ARR) RET
S WPI=0 F S WPI=$O(ARR(WPI)) Q:WPI="" D
.S RET=RET_ARR(WPI)
Q RET
PF(STRING,SUB,DI) ;piece find
N SDI
S STRING=$G(STRING) Q:STRING="" ""
S SUB=$G(SUB) Q:SUB="" ""
S DI=$G(DI) S:DI="" DI=U
F SDI=1:1:$L(STRING,DI) Q:$P(STRING,DI,SDI)=SUB
Q SDI
PD(STRING,PC,DI) ;piece delete
N SDI,NSTR
S NSTR=""
S STRING=$G(STRING) Q:STRING="" STRING
S PC=$G(PC) Q:'PC STRING
S DI=$G(DI) S:DI="" DI=U
F SDI=1:1:$L(STRING,DI) D
.Q:SDI=PC
.S NSTR=NSTR_$S(NSTR'="":DI,1:"")_$P(STRING,DI,SDI)
Q NSTR
PFD(STRING,SUB,DI) ;piece find/delete delete all pieces with matching SUB values
N SDI,NSTR
S NSTR=""
S STRING=$G(STRING) Q:STRING="" STRING
S SUB=$G(SUB) Q:SUB="" STRING
S DI=$G(DI) S:DI="" DI=U
F SDI=1:1:$L(STRING,DI) S:$P(STRING,DI,SDI)'=SUB NSTR=NSTR_$S(NSTR'="":DI,1:"")_$P(STRING,DI,SDI)
Q NSTR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECUTL 12944 printed Sep 23, 2025@20:29:18 Page 2
SDECUTL ;ALB/MGD - VISTA SCHEDULING RPCS ;Jul 02, 2021@16:42
+1 ;;5.3;Scheduling;**627,658,665,790**;Aug 13, 1993;Build 11
+2 ;
+3 ; Reference to ^GMR(123 is supported by IA #4837
+4 QUIT
+5 ;
SYSSTAT(SDECY) ; SYSTEM STATUS
+1 ;SYSSTAT(SDECY) external parameter tag in SDEC
+2 NEW SDECCNT,SDECD,SDECH,SDECII,SDECROW,SDECROW1,SDECYA
+3 SET SDECII=0
+4 SET SDECY=$NAME(^TMP("SDEC",$JOB))
KILL @SDECY
+5 ;S SDECYA=$NA(^SDECTMPA($J)) K @SDECYA
+6 SET @SDECY@(SDECII)="T00080ERROR_ID^T00080ERROR_TEXT"_$CHAR(30)
+7 SET SDECII=SDECII+1
SET @SDECY@(SDECII)=$CHAR(30,31)
+8 QUIT
+9 ;
STRIP(SDECSTR) ;
+1 ; SDECSTR = input string to parse
+2 NEW SDECDN,SDECI,SDECPC,SDECPCNT,SDECPDN,SDECRET
+3 if $EXTRACT(SDECSTR,1,8)=" "
QUIT ""
+4 SET SDECI=""
+5 SET SDECRET=""
+6 SET SDECPCNT=""
+7 SET SDECDN=""
+8 FOR
if SDECDN
QUIT
Begin DoDot:1
+9 SET SDECI=SDECI+1
+10 if $EXTRACT(SDECSTR,SDECI)=" "
QUIT
+11 SET SDECPCNT=SDECPCNT+1
+12 SET SDECPC=""
+13 SET SDECPDN=""
+14 FOR
if SDECPDN
QUIT
Begin DoDot:2
+15 SET SDECPC=SDECPC_$EXTRACT(SDECSTR,SDECI)
+16 SET SDECI=SDECI+1
+17 IF ($EXTRACT(SDECSTR,SDECI)=" ")!(SDECI>$LENGTH(SDECSTR))
SET SDECPDN=1
End DoDot:2
+18 ;
+19 SET SDECRET=$SELECT(SDECPCNT'=1:SDECRET_U,1:"")_$SELECT(SDECPCNT=4:$EXTRACT(SDECPC,1,8),1:SDECPC)
+20 IF (SDECPCNT=4)!(SDECI>$LENGTH(SDECSTR))
SET SDECDN=1
End DoDot:1
+21 ;
+22 QUIT SDECRET
+23 ;
FL(SDECSTR,SDECW,SDECD) ;EP
+1 ;format line
+2 ; SDECSTR = Text String to be formatted
+3 ; SDECW = Maximum width of text line
+4 ; SDECD = Delimiter; defaults to double pipe "||" to be used as the line separator
+5 ;
+6 ;RETURNS string delimited by double pipe "||" to be used as line separator
+7 NEW SDECOUT,SDECPTR,SDECTMP
+8 IF $GET(SDECW)=""
SET SDECW=80
+9 IF '+SDECW
SET SDECW=80
+10 IF $LENGTH(SDECSTR)'>SDECW
QUIT SDECSTR
+11 IF $GET(SDECD)=""
SET SDECD="||"
+12 SET SDECOUT=""
+13 SET SDECPTR=SDECW
+14 ;handle no spaces in the string
+15 IF SDECSTR'[" "
Begin DoDot:1
+16 FOR
if SDECSTR=""
QUIT
Begin DoDot:2
+17 IF $LENGTH(SDECSTR)'>SDECW
Begin DoDot:3
+18 SET SDECOUT=$SELECT(SDECOUT'="":SDECOUT_SDECD,1:"")_SDECSTR
+19 SET SDECSTR=""
End DoDot:3
+20 IF $LENGTH(SDECSTR)>SDECW
Begin DoDot:3
+21 SET SDECOUT=$SELECT(SDECOUT'="":SDECOUT_SDECD,1:"")_$EXTRACT(SDECSTR,1,SDECW)
+22 SET SDECSTR=$EXTRACT(SDECSTR,SDECW+1,$LENGTH(SDECSTR))
End DoDot:3
End DoDot:2
End DoDot:1
+23 ;string does contain a space
+24 IF SDECSTR[" "
Begin DoDot:1
+25 FOR
if SDECSTR=""
QUIT
Begin DoDot:2
+26 IF $LENGTH(SDECSTR)'>SDECW
Begin DoDot:3
+27 SET SDECOUT=$SELECT(SDECOUT'="":SDECOUT_SDECD,1:"")_SDECSTR
+28 SET SDECSTR=""
End DoDot:3
+29 IF $LENGTH(SDECSTR)>SDECW
Begin DoDot:3
+30 FOR
if $EXTRACT(SDECSTR,SDECPTR)=" "
QUIT
Begin DoDot:4
+31 SET SDECPTR=SDECPTR-1
End DoDot:4
+32 SET SDECOUT=$SELECT(SDECOUT'="":SDECOUT_SDECD,1:"")_$EXTRACT(SDECSTR,1,SDECPTR-1)
+33 SET SDECSTR=$EXTRACT(SDECSTR,SDECPTR+1,$LENGTH(SDECSTR))
+34 SET SDECPTR=SDECW
End DoDot:3
End DoDot:2
End DoDot:1
+35 QUIT SDECOUT
+36 ;
+37 ; Check and validate visit
CHKVISIT(VIEN,DFN,CAT) ;EP
+1 NEW RET,X0
+2 SET RET=$$ISLOCKED(VIEN)
+3 if RET
QUIT $SELECT(RET<0:$$ERR^SDEC44("Visit "_VIEN_" not found."),1:$$ERR^SDEC44("Visit "_VIEN_" is locked."))
+4 SET X0=$GET(^AUPNVSIT(VIEN,0))
+5 IF $GET(DFN)
IF $PIECE(X0,U,5)'=DFN
SET RET=$$ERR^SDEC44("Visit "_VIEN_" does not belong to Patient "_DFN_".")
+6 IF '$TEST
IF $PIECE(X0,U,11)
SET RET=$$ERR^SDEC44("Visit "_VIEN_" has been deleted.")
+7 IF '$TEST
IF $LENGTH($GET(CAT))
IF CAT'[$PIECE(X0,U,7)
SET RET=$$ERR^SDEC44("Service Category of Visit "_VIEN_" is not "_CAT_".",$$EXTERNAL^DILFD(9000010,.07,,$PIECE(X0,U,7)))
+8 QUIT RET
+9 ;
+10 ; Returns visit lock status:
+11 ; -1: Visit not found
+12 ; 0: Visit is not locked
+13 ; 1: Visit is locked
ISLOCKED(IEN) ;PEP - Is visit locked?
+1 NEW DAT,DAYS,EXPDT
+2 SET DAT=$$VISREFDT(IEN)
+3 if 'DAT
QUIT -1
+4 ;IHS/MSC/PLS - 02/18/09 - Parameter now holds lock expiration date
+5 ;S EXPDT=$$GET^XPAR("USR","BEHOENCX VISIT LOCK OVERRIDE","`"_IEN)
+6 ;Q:EXPDT'<$$DT^XLFDT() 0
+7 ;D:EXPDT DEL^XPAR("USR","BEHOENCX VISIT LOCK OVERRIDE","`"_IEN) ; remove expired locked
+8 ;Q:$$GET^XPAR("USR","BEHOENCX VISIT LOCK OVERRIDE","`"_IEN) 0
+9 ;S DAYS=$$GET^XPAR("ALL","BEHOENCX VISIT LOCKED")
+10 ;$S(DAYS<1:1,1:DAYS)
QUIT $$FMDIFF^XLFDT(DT,DAT)>1
+11 ; Returns reference date for visit lock check
VISREFDT(IEN) ;
+1 NEW ADM,DIS,DAT
+2 SET DAT=$PIECE($GET(^AUPNVSIT(+IEN,0)),U,2)
+3 if 'DAT
QUIT ""
+4 SET ADM=$ORDER(^DGPM("AVISIT",IEN,0))
+5 if 'ADM
QUIT DAT
+6 SET DIS=$PIECE($GET(^DGPM(ADM,0)),U,17)
+7 QUIT $SELECT(DIS:$PIECE($GET(^DGPM(DIS,0)),U),1:DT)
+8 ;
+9 ; Add/edit a file entry
UPDATE(FDA,FLG,IEN) ;EP
+1 NEW ERR,DFN,X
+2 IF $GET(FLG)["@"
SET FLG=$TRANSLATE(FLG,"@")
+3 IF '$TEST
Begin DoDot:1
+4 SET X="FDA"
+5 FOR
SET X=$QUERY(@X)
if '$LENGTH(X)
QUIT
if '$LENGTH(@X)
KILL @X
End DoDot:1
+6 if $DATA(FDA)'>1
QUIT ""
+7 DO UPDATE^DIE(.FLG,"FDA","IEN","ERR")
+8 KILL FDA
+9 QUIT $SELECT($GET(ERR("DIERR",1)):-ERR("DIERR",1)_U_ERR("DIERR",1,"TEXT",1),1:"")
+10 ;
ISACTIVE(ADT,IDT,CDT) ;is CDT an active date given an active date and inactive date
+1 ;INPUT:
+2 ; ADT = Activation date in FM format
+3 ; IDT = Inactivation date in FM format
+4 ; CDT = date to check - default to 'today'
+5 ;RETURN:
+6 ; 0=inactive
+7 ; 1=active
+8 ; 2=ADT & IDT null; calling routine can decide if default to active or inactive
+9 ; 3=date to check is before both activation and inactivation; calling routine can decide if default to active or inactive
+10 NEW RET
+11 SET RET=""
+12 SET ADT=$SELECT($PIECE($GET(ADT),".",1)?7N:$PIECE(ADT,".",1),1:"")
+13 SET IDT=$SELECT($PIECE($GET(IDT),".",1)?7N:$PIECE(IDT,".",1),1:"")
+14 SET CDT=$SELECT($PIECE($GET(CDT),".",1)?7N:$PIECE(CDT,".",1),1:$PIECE($$NOW^XLFDT,".",1))
+15 ;0 0
+16 IF ADT=""
IF IDT=""
SET RET=2
+17 if RET'=""
QUIT RET
+18 ;1 0
+19 IF ADT'=""
IF IDT=""
Begin DoDot:1
+20 ;TODO: what if 'today' or CDT is before ADT
SET RET=1
End DoDot:1
+21 if RET'=""
QUIT RET
+22 ;0 1
+23 ;TODO: what if 'today' or CDT is before IDT
IF ADT=""
IF IDT'=""
SET RET=0
+24 if RET'=""
QUIT RET
+25 ;1 1
+26 ; active < T < inactive
+27 IF CDT'<ADT
IF CDT'>IDT
SET RET=1
+28 if RET'=""
QUIT RET
+29 ; active < inactive < T
+30 IF ADT<IDT
IF IDT<CDT
SET RET=0
+31 if RET'=""
QUIT RET
+32 ; inactive < T < active
+33 IF IDT<CDT
IF CDT<ADT
SET RET=0
+34 if RET'=""
QUIT RET
+35 ; inactive < active < T
+36 IF IDT<ADT
IF ADT<CDT
SET RET=1
+37 if RET'=""
QUIT RET
+38 ;T < active < inactive AND T < inactive < active
+39 ;should not get here
IF RET=""
SET RET=3
+40 QUIT RET
+41 ;
APPTGET(DFN,SDBEG,SDCL,SDRES) ;get SDEC APPOINTMENT for given patient, time, and clinic
+1 NEW SDAPPT,SDI,SDNOD,SDRCL,SDARES,SDBEGINDX,SDEND
+2 SET SDAPPT=""
+3 SET SDCL=$GET(SDCL)
+4 SET SDRES=$GET(SDRES)
+5 ; Reset SDBEG to immediately before actual start time
+6 SET SDBEGINDX=SDBEG-.00001
+7 ; Set stop date
SET SDEND=$EXTRACT(SDBEG,1,7)
+8 ; Utilize APTDT x-ref for speed. VSE-1172
+9 FOR
SET SDBEGINDX=$ORDER(^SDEC(409.84,"APTDT",DFN,SDBEGINDX))
if 'SDBEGINDX!($PIECE(SDBEGINDX,".",1)>SDEND)
QUIT
Begin DoDot:1
+10 SET SDI=0
FOR
SET SDI=$ORDER(^SDEC(409.84,"APTDT",DFN,SDBEGINDX,SDI))
if SDI'>0
QUIT
Begin DoDot:2
+11 SET SDNOD=$GET(^SDEC(409.84,SDI,0))
+12 ; Quit if this record has one of the Cancelled Statuses. VSE-1171
+13 if "^N^NA^C^CA^PC^PCA^"[(U_$PIECE(SDNOD,U,17)_U)
QUIT
+14 if SDBEG'=$PIECE(SDNOD,U,1)
QUIT
+15 IF +SDRES
if +SDRES'=$PIECE(SDNOD,U,7)
QUIT
+16 IF 'SDRES
SET SDARES=$PIECE(SDNOD,U,7)
SET SDRCL=$PIECE($GET(^SDEC(409.831,+SDARES,0)),U,4)
if SDRCL'=SDCL
QUIT
+17 SET SDAPPT=SDI
End DoDot:2
if SDAPPT'=""
QUIT
End DoDot:1
if SDAPPT'=""
QUIT
+18 QUIT SDAPPT
+19 ;
GETRES(SDCL,INACT) ;get resource for clinic - SDEC RESOURCE
+1 NEW SDHLN,SDI,SDNOD,SDRES,SDRES1
+2 SET (SDRES,SDRES1)=""
+3 SET SDHLN=$PIECE($GET(^SC(SDCL,0)),U,1)
+4 if SDHLN=""
QUIT ""
+5 SET SDI=""
FOR
SET SDI=$ORDER(^SDEC(409.831,"ALOC",SDCL,SDI))
if SDI=""
QUIT
Begin DoDot:1
+6 SET SDNOD=$GET(^SDEC(409.831,SDI,0))
+7 IF '$GET(INACT)
if $$GET1^DIQ(409.831,SDI_",",.02)="YES"
QUIT
+8 if SDRES1=""
SET SDRES1=SDI
+9 if $PIECE($PIECE(SDNOD,U,11),";",2)'="SC("
QUIT
+10 SET SDRES=SDI
+11 ;I $$UP^XLFSTR($P(SDNOD,U,1))=SDHLN S SDRES=SDI
End DoDot:1
if SDRES'=""
QUIT
+12 IF SDRES=""
IF SDRES1'=""
SET SDRES=SDRES1
+13 QUIT SDRES
+14 ;
RECALL(DFN,SDT,SDCL) ;is this appointment for RECALL
+1 ;INPUT:
+2 ; DFN = Patient ID pointer to PATIENT file 2
+3 ; SDT = Appointment date/time in fm format
+4 NEW SDI,SDNOD1,SDRET
+5 SET SDRET=""
+6 SET SDI=0
FOR
SET SDI=$ORDER(^SD(403.56,"B",DFN,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+7 SET SDNOD1=$GET(^SD(403.56,SDI,1))
+8 if $PIECE(SDNOD1,U,1)'=SDT
QUIT
+9 if $PIECE(SDNOD1,U,2)'=SDCL
QUIT
+10 SET SDRET=SDI
End DoDot:1
if SDRET'=""
QUIT
+11 QUIT SDRET
+12 ;
SDCL(SDAPID) ;get clinic for given SDEC APPOINTMENT id
+1 ;INPUT:
+2 ; SDAPID - appt ID pointer to SDEC APPOINTMENT file 409.84
+3 ;RETURN:
+4 ; Clinic ID pointer to HOSPITAL LOCATION file 44
+5 NEW SDAPTYP,SDCL
+6 SET SDCL=""
+7 SET SDAPTYP=$$GET1^DIQ(409.84,SDAPID_",",.22,"I")
+8 if $PIECE(SDAPTYP,"|",2)="SDWL(409.3,"
SET SDCL=$$GET1^DIQ(409.3,$PIECE(SDAPTYP,"|",2)_",",13.2,"I")
+9 if $PIECE(SDAPTYP,"|",1)="SD(403.5,"
SET SDCL=$$GET1^DIQ(403.5,$PIECE(SDAPTYP,"|",2)_",",4.5,"I")
+10 ;ICR 4837
if $PIECE(SDAPTYP,"|",1)="GMR(123,"
SET SDCL=$$GET1^DIQ(123,$PIECE(SDAPTYP,"|",2)_",",.04,"I")
+11 QUIT SDCL
+12 ;
PTSEC(DFN) ;patient sensitive & record access checks; calls DG SENSITIVE RECORD ACCESS api
+1 ;INPUT:
+2 ; DFN - patient ID pointer to PATIENT file 2
+3 ;RETURN:
+4 ; RESULT - the following pipe pieces:
+5 ; 1. return code:
+6 ; -1-RPC/API failed
+7 ; Required variable not defined
+8 ; 0-No display/action required
+9 ; Not accessing own, employee, or sensitive record
+10 ; 1-Display warning message
+11 ; Sensitive and DG SENSITIVITY key holder
+12 ; or Employee and DG SECURITY OFFICER key holder
+13 ; 2-Display warning message/require OK to continue
+14 ; Sensitive and not a DG SENSITIVITY key holder
+15 ; Employee and not a DG SECURITY OFFICER key holder
+16 ; 3-Access to record denied
+17 ; Accessing own record
+18 ; 4-Access to Patient (#2) file records denied
+19 ; SSN not defined
+20 ; 2. display text/message
+21 ; 3. display text/message
+22 ; 4. display text/message
+23 ;
+24 NEW SDI,SDLINE,SDRET,SDSEC,SDTXT
+25 KILL SDRET,SDSEC
+26 SET SDRET=""
+27 ;D PTSEC^DGSEC4(.SDSEC,DFN,0) ;alb/sat 658
+28 DO PTSEC4(.SDSEC,DFN,0)
+29 SET $PIECE(SDRET,"|",1)=SDSEC(1)
+30 ;I DUZ=51 S:$G(SDSEC(2))'="" $P(SDRET,"|",2)=$$STRIP1(SDSEC(2))
if $GET(SDSEC(2))'=""
SET $PIECE(SDRET,"|",2)=SDSEC(2)
+31 ;I DUZ=51 S:$G(SDSEC(3))'="" $P(SDRET,"|",3)=$$STRIP1(SDSEC(3))
if $GET(SDSEC(3))'=""
SET $PIECE(SDRET,"|",3)=SDSEC(3)
+32 SET SDTXT=""
+33 SET SDI=3
FOR
SET SDI=$ORDER(SDSEC(SDI))
if SDI=""
QUIT
Begin DoDot:1
+34 SET SDLINE=$$STRIP1(SDSEC(SDI))
+35 if SDLINE?." "
QUIT
+36 SET SDTXT=$SELECT(SDTXT'="":SDTXT,1:"")_SDLINE
End DoDot:1
+37 if SDTXT'=""
SET $PIECE(SDRET,"|",4)=SDTXT
+38 QUIT SDRET
PTSEC4(RESULT,DFN,DGMSG,DGOPT) ;RPC/API entry point for patient sensitive & record access checks ;alb/sat 658
+1 ;Output array (Required)
+2 ; RESULT(1)= -1-RPC/API failed
+3 ; Required variable not defined
+4 ; 0-No display/action required
+5 ; Not accessing own, employee, or sensitive record
+6 ; 1-Display warning message
+7 ; Sensitive and DG SENSITIVITY key holder
+8 ; or Employee and DG SECURITY OFFICER key holder
+9 ; 2-Display warning message/require OK to continue
+10 ; Sensitive and not a DG SENSITIVITY key holder
+11 ; Employee and not a DG SECURITY OFFICER key holder
+12 ; 3-Access to record denied
+13 ; Accessing own record
+14 ; 4-Access to Patient (#2) file records denied
+15 ; SSN not defined
+16 ; RESULT(2-10) = error or display messages
+17 ;
+18 ;Input parameters: DFN = Patient file entry (Required)
+19 ; DGMSG = If 1, generate message (optional)
+20 ; DGOPT = Option name^Menu text (Optional)
+21 ;
+22 KILL RESULT
+23 IF $GET(DFN)=""
Begin DoDot:1
+24 SET RESULT(1)=-1
+25 SET RESULT(2)="Required variable missing."
End DoDot:1
QUIT
+26 SET DGMSG=$GET(DGMSG,0)
+27 DO OWNREC^DGSEC4(.RESULT,DFN,$GET(DUZ),DGMSG)
+28 IF RESULT(1)=1
SET RESULT(1)=3
QUIT
+29 IF RESULT(1)=2
SET RESULT(1)=4
QUIT
+30 KILL RESULT
+31 DO SENS^DGSEC4(.RESULT,DFN,$GET(DUZ))
+32 IF RESULT(1)=1
Begin DoDot:1
+33 IF $GET(DUZ)=""
Begin DoDot:2
+34 ;DUZ must be defined to access sensitive record & update DG Security log
+35 SET RESULT(1)=-1
+36 SET RESULT(2)="Your user code is undefined. This must be defined to access a restricted patient record."
End DoDot:2
QUIT
+37 ;D SETLOG1^DGSEC(DFN,DUZ,,$G(DGOPT))
End DoDot:1
+38 QUIT
+39 ;
STRIP1(SDTXT) ;strip out "*"
+1 NEW SDI
+2 SET SDTXT=$TRANSLATE(SDTXT,"*","")
+3 FOR SDI=$LENGTH(SDTXT):-1:1
if $EXTRACT(SDTXT,SDI)'=" "
QUIT
SET SDTXT=$EXTRACT(SDTXT,1,$LENGTH(SDTXT)-1)
+4 QUIT SDTXT
+5 ;
WP(RET,STR,CH) ;Convert string STR to Word Processing array ;alb/sat 658
+1 ;INPUT:
+2 ; STR - String to convert
+3 ; CH - Max characters per line
+4 ;RETURN:
+5 ; RET - WP Array RET(<line cnt>,0)=<text>
+6 NEW CH1,CNT,BEG,END,LCNT
+7 KILL RET
+8 if $GET(STR)=""
QUIT
+9 IF '+$GET(CH)
SET CH=80
+10 ;alb/sat 665
IF $LENGTH(STR'>CH)
SET RET(1,0)=STR
QUIT
+11 SET (END,LCNT)=0
+12 SET BEG=1
+13 FOR CNT=1:1:$LENGTH(STR)
SET CH1=$EXTRACT(STR,CNT)
Begin DoDot:1
+14 IF CH1=" "
SET END=CNT
+15 IF CNT'=BEG
IF '((CNT-BEG)#CH)
Begin DoDot:2
+16 SET LCNT=LCNT+1
SET RET(LCNT,0)=$EXTRACT(STR,BEG,$SELECT(END'=0:END,1:CNT))
+17 SET BEG=$SELECT(END'=0:END,1:CNT)+1
+18 SET END=0
End DoDot:2
End DoDot:1
+19 IF CNT'=BEG
SET LCNT=LCNT+1
SET RET(LCNT,0)=$EXTRACT(STR,BEG,$LENGTH(STR))
+20 QUIT
WPSTR(ARR) ;convert WP field array to single string ;alb/sat 658
+1 NEW RET,WPI
+2 SET RET=""
+3 if '$DATA(ARR)
QUIT RET
+4 SET WPI=0
FOR
SET WPI=$ORDER(ARR(WPI))
if WPI=""
QUIT
Begin DoDot:1
+5 SET RET=RET_ARR(WPI)
End DoDot:1
+6 QUIT RET
PF(STRING,SUB,DI) ;piece find
+1 NEW SDI
+2 SET STRING=$GET(STRING)
if STRING=""
QUIT ""
+3 SET SUB=$GET(SUB)
if SUB=""
QUIT ""
+4 SET DI=$GET(DI)
if DI=""
SET DI=U
+5 FOR SDI=1:1:$LENGTH(STRING,DI)
if $PIECE(STRING,DI,SDI)=SUB
QUIT
+6 QUIT SDI
PD(STRING,PC,DI) ;piece delete
+1 NEW SDI,NSTR
+2 SET NSTR=""
+3 SET STRING=$GET(STRING)
if STRING=""
QUIT STRING
+4 SET PC=$GET(PC)
if 'PC
QUIT STRING
+5 SET DI=$GET(DI)
if DI=""
SET DI=U
+6 FOR SDI=1:1:$LENGTH(STRING,DI)
Begin DoDot:1
+7 if SDI=PC
QUIT
+8 SET NSTR=NSTR_$SELECT(NSTR'="":DI,1:"")_$PIECE(STRING,DI,SDI)
End DoDot:1
+9 QUIT NSTR
PFD(STRING,SUB,DI) ;piece find/delete delete all pieces with matching SUB values
+1 NEW SDI,NSTR
+2 SET NSTR=""
+3 SET STRING=$GET(STRING)
if STRING=""
QUIT STRING
+4 SET SUB=$GET(SUB)
if SUB=""
QUIT STRING
+5 SET DI=$GET(DI)
if DI=""
SET DI=U
+6 FOR SDI=1:1:$LENGTH(STRING,DI)
if $PIECE(STRING,DI,SDI)'=SUB
SET NSTR=NSTR_$SELECT(NSTR'="":DI,1:"")_$PIECE(STRING,DI,SDI)
+7 QUIT NSTR
