Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDECUTL

SDECUTL.m

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