- 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 Jan 18, 2025@03:54 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