SDECU2 ;ALB/SAT - VISTA SCHEDULING RPCS ;MAR 15, 2017
;;5.3;Scheduling;**627,658,671**;Aug 13, 1993;Build 25
;
Q
;
SCIEN(PAT,CLINIC,DATE) ;PEP; returns ien for appt in ^SC
NEW X,IEN
S X=0 F S X=$O(^SC(CLINIC,"S",DATE,1,X)) Q:'X Q:$G(IEN) D
. Q:$P($G(^SC(CLINIC,"S",DATE,1,X,0)),U,9)="C" ;cancelled
. I +$G(^SC(CLINIC,"S",DATE,1,X,0))=PAT S IEN=X
Q $G(IEN)
;
CI(PAT,CLINIC,DATE,SDIEN) ;PEP; -- returns 1 if appt already checked-in
NEW X
S X=$G(SDIEN) ;ien sent in call
I 'X S X=$$SCIEN(PAT,CLINIC,DATE) I 'X Q 0
S X=$P($G(^SC(CLINIC,"S",DATE,1,X,"C")),U)
Q $S(X:1,1:0)
;
APPTYP(PAT,DATE) ;PEP; -- returns type of appt (scheduled or walk-in)
NEW X S X=$P($G(^DPT(PAT,"S",DATE,0)),U,7)
Q $S(X=3:"SCHED",X=4:"WALK-IN",1:"??")
;
CO(PAT,CLINIC,DATE,SDIEN) ;PEP; -- returns 1 if appt already checked-out
NEW X
S X=$G(SDIEN) ;ien sent in call
I 'X S X=$$SCIEN(PAT,CLINIC,DATE) I 'X Q 0
S X=$P($G(^SC(CLINIC,"S",DATE,1,X,"C")),U,3)
Q $S(X:1,1:0)
;
GETVST(PAT,DATE) ;PEP; returns visit ien for appt date and patient
NEW X
I ('PAT)!('DATE) Q 0
S X=$G(^DPT(PAT,"S",DATE,0)) I 'X Q 0 ;appt node
S X=$P(X,U,20) I 'X Q 0 ;outpt encounter ptr
S X=$G(^SCE(X,0)) I 'X Q 0 ;outpt encounter node
I $P(X,U,2)'=PAT Q 0 ;patient ptr
Q $P(X,U,5) ;visit ptr
;
FLAGS(DFN,FNUM) ;get PRF flags
;INPUT:
; DFN - Patient ID
; FNUM - PRF Flag file ID 26.15=PRF NATIONAL FLAG 26.11=PRF LOCAL FLAG
;RETURN:
; Each | piece contains the following ;; pieces:
; 1. PRFAID - PRF Assignment ID pointer to PRF ASSIGNMENT file (#26.13)
; 2. PRFSTAT - PRF Assignment Status 0=INACTIVE 1=ACTIVE
; 3. PRFLID - PRF Local Flag ID pointer to PRF LOCAL FLAG file (#26.11)
; 4. PRFLNAME - PRF Local Flag name
; 5. PRFLSTAT - PRF Local Flag status 0=INACTIVE 1=ACTIVE
;
N PRFAID,PRFID,PRFLST,RET,STAT
S RET=""
S DFN=$G(DFN)
Q:DFN="" ""
Q:'$D(^DPT(DFN,0)) ""
S FNUM=$G(FNUM)
Q:(FNUM'=26.15)&(FNUM'=26.11) ""
D FLST(.PRFLIST,FNUM)
S PRFID="" F S PRFID=$O(PRFLIST(PRFID)) Q:PRFID="" D
.S PRFAID="" F S PRFAID=$O(^DGPF(26.13,"AFLAG",PRFID,DFN,PRFAID)) Q:PRFAID="" D
..S STAT="" S STAT=$$GET1^DIQ(26.13,PRFAID_",",.03,"I") Q:STAT'=1
..S RET=RET_$S(RET'="":"|",1:"")_PRFAID_";;"_STAT_";;"_+PRFID_";;"_$P(PRFLIST(PRFID),U,1)_";;"_$P(PRFLIST(PRFID),U,2)
Q RET
FLST(PRFLIST,FNUM) ;build flag list
N PRFID,PRFN
K PRFLIST
S PRFN="" F S PRFN=$O(^DGPF(FNUM,"B",PRFN)) Q:PRFN="" D
.S PRFID="" F S PRFID=$O(^DGPF(FNUM,"B",PRFN,PRFID)) Q:PRFID="" D
..S PRFLIST(PRFID_";DGPF("_FNUM_",")=$$GET1^DIQ(FNUM,PRFID_",",.01)_U_$$GET1^DIQ(FNUM,PRFID_",",.02,"I")
Q
;
GAF(DFN) ;determine if GAF score needed
N GAF,GAFR
S GAFR=""
S GAF=$$NEWGAF^SDUTL2(DFN)
S:GAF="" GAF=-1
S $P(GAFR,"|",1)=$S(+GAF:"New GAF Required",1:"No new GAF required")
;S $P(GAFR,"|",2)=$P(GAF,U,2) ;alb/sat 658 removed 4 lines
;S $P(GAFR,"|",3)=$$FMTE^XLFDT($P(GAF,U,3))
;S $P(GAFR,"|",4)=$P(GAF,U,4)
;S $P(GAFR,"|",5)=$P($G(^VA(200,+$P(GAF,U,4),0)),U,1)
Q GAFR
;
ETH(DFN,PETH,PETHN) ;get ethnicity list
;INPUT:
; DFN = Patient ID pointer to PATIENT file
;RETURN:
; PETH - Patient Ethnicity list separated by pipe |
; Pointer to ETHNICITY file 10.2
; PETHN - Patient Ethnicity names separated by pipe |
N SDI,SDID
S (PETH,PETHN)=""
S SDI=0 F S SDI=$O(^DPT(DFN,.06,SDI)) Q:SDI'>0 D
.S SDID=$P($G(^DPT(DFN,.06,SDI,0)),U,1)
.S PETH=$S(PETH'="":PETH_"|",1:"")_SDID
.S PETHN=$S(PETHN'="":PETHN_"|",1:"")_$P($G(^DIC(10.2,SDID,0)),U,1)
Q
RACELST(DFN,RACEIEN,RACENAM) ;get list of race information for given patient
;INPUT:
; DFN = Patient ID pointer to PATIENT file
;RETURN:
; RACEIEN - Patient race list separated by pipe |
; Pointer to RACE file 10
; RACENAM - Patient race names separated by pipe |
N SDI,SDID
S (RACEIEN,RACENAM)=""
S SDI=0 F S SDI=$O(^DPT(DFN,.02,SDI)) Q:SDI'>0 D
.S SDID=$P($G(^DPT(DFN,.02,SDI,0)),U,1)
.S RACEIEN=$S(RACEIEN'="":RACEIEN_"|",1:"")_SDID
.S RACENAM=$S(RACENAM'="":RACENAM_"|",1:"")_$P($G(^DIC(10,SDID,0)),U,1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECU2 4214 printed Oct 16, 2024@18:53:22 Page 2
SDECU2 ;ALB/SAT - VISTA SCHEDULING RPCS ;MAR 15, 2017
+1 ;;5.3;Scheduling;**627,658,671**;Aug 13, 1993;Build 25
+2 ;
+3 QUIT
+4 ;
SCIEN(PAT,CLINIC,DATE) ;PEP; returns ien for appt in ^SC
+1 NEW X,IEN
+2 SET X=0
FOR
SET X=$ORDER(^SC(CLINIC,"S",DATE,1,X))
if 'X
QUIT
if $GET(IEN)
QUIT
Begin DoDot:1
+3 ;cancelled
if $PIECE($GET(^SC(CLINIC,"S",DATE,1,X,0)),U,9)="C"
QUIT
+4 IF +$GET(^SC(CLINIC,"S",DATE,1,X,0))=PAT
SET IEN=X
End DoDot:1
+5 QUIT $GET(IEN)
+6 ;
CI(PAT,CLINIC,DATE,SDIEN) ;PEP; -- returns 1 if appt already checked-in
+1 NEW X
+2 ;ien sent in call
SET X=$GET(SDIEN)
+3 IF 'X
SET X=$$SCIEN(PAT,CLINIC,DATE)
IF 'X
QUIT 0
+4 SET X=$PIECE($GET(^SC(CLINIC,"S",DATE,1,X,"C")),U)
+5 QUIT $SELECT(X:1,1:0)
+6 ;
APPTYP(PAT,DATE) ;PEP; -- returns type of appt (scheduled or walk-in)
+1 NEW X
SET X=$PIECE($GET(^DPT(PAT,"S",DATE,0)),U,7)
+2 QUIT $SELECT(X=3:"SCHED",X=4:"WALK-IN",1:"??")
+3 ;
CO(PAT,CLINIC,DATE,SDIEN) ;PEP; -- returns 1 if appt already checked-out
+1 NEW X
+2 ;ien sent in call
SET X=$GET(SDIEN)
+3 IF 'X
SET X=$$SCIEN(PAT,CLINIC,DATE)
IF 'X
QUIT 0
+4 SET X=$PIECE($GET(^SC(CLINIC,"S",DATE,1,X,"C")),U,3)
+5 QUIT $SELECT(X:1,1:0)
+6 ;
GETVST(PAT,DATE) ;PEP; returns visit ien for appt date and patient
+1 NEW X
+2 IF ('PAT)!('DATE)
QUIT 0
+3 ;appt node
SET X=$GET(^DPT(PAT,"S",DATE,0))
IF 'X
QUIT 0
+4 ;outpt encounter ptr
SET X=$PIECE(X,U,20)
IF 'X
QUIT 0
+5 ;outpt encounter node
SET X=$GET(^SCE(X,0))
IF 'X
QUIT 0
+6 ;patient ptr
IF $PIECE(X,U,2)'=PAT
QUIT 0
+7 ;visit ptr
QUIT $PIECE(X,U,5)
+8 ;
FLAGS(DFN,FNUM) ;get PRF flags
+1 ;INPUT:
+2 ; DFN - Patient ID
+3 ; FNUM - PRF Flag file ID 26.15=PRF NATIONAL FLAG 26.11=PRF LOCAL FLAG
+4 ;RETURN:
+5 ; Each | piece contains the following ;; pieces:
+6 ; 1. PRFAID - PRF Assignment ID pointer to PRF ASSIGNMENT file (#26.13)
+7 ; 2. PRFSTAT - PRF Assignment Status 0=INACTIVE 1=ACTIVE
+8 ; 3. PRFLID - PRF Local Flag ID pointer to PRF LOCAL FLAG file (#26.11)
+9 ; 4. PRFLNAME - PRF Local Flag name
+10 ; 5. PRFLSTAT - PRF Local Flag status 0=INACTIVE 1=ACTIVE
+11 ;
+12 NEW PRFAID,PRFID,PRFLST,RET,STAT
+13 SET RET=""
+14 SET DFN=$GET(DFN)
+15 if DFN=""
QUIT ""
+16 if '$DATA(^DPT(DFN,0))
QUIT ""
+17 SET FNUM=$GET(FNUM)
+18 if (FNUM'=26.15)&(FNUM'=26.11)
QUIT ""
+19 DO FLST(.PRFLIST,FNUM)
+20 SET PRFID=""
FOR
SET PRFID=$ORDER(PRFLIST(PRFID))
if PRFID=""
QUIT
Begin DoDot:1
+21 SET PRFAID=""
FOR
SET PRFAID=$ORDER(^DGPF(26.13,"AFLAG",PRFID,DFN,PRFAID))
if PRFAID=""
QUIT
Begin DoDot:2
+22 SET STAT=""
SET STAT=$$GET1^DIQ(26.13,PRFAID_",",.03,"I")
if STAT'=1
QUIT
+23 SET RET=RET_$SELECT(RET'="":"|",1:"")_PRFAID_";;"_STAT_";;"_+PRFID_";;"_$PIECE(PRFLIST(PRFID),U,1)_";;"_$PIECE(PRFLIST(PRFID),U,2)
End DoDot:2
End DoDot:1
+24 QUIT RET
FLST(PRFLIST,FNUM) ;build flag list
+1 NEW PRFID,PRFN
+2 KILL PRFLIST
+3 SET PRFN=""
FOR
SET PRFN=$ORDER(^DGPF(FNUM,"B",PRFN))
if PRFN=""
QUIT
Begin DoDot:1
+4 SET PRFID=""
FOR
SET PRFID=$ORDER(^DGPF(FNUM,"B",PRFN,PRFID))
if PRFID=""
QUIT
Begin DoDot:2
+5 SET PRFLIST(PRFID_";DGPF("_FNUM_",")=$$GET1^DIQ(FNUM,PRFID_",",.01)_U_$$GET1^DIQ(FNUM,PRFID_",",.02,"I")
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
GAF(DFN) ;determine if GAF score needed
+1 NEW GAF,GAFR
+2 SET GAFR=""
+3 SET GAF=$$NEWGAF^SDUTL2(DFN)
+4 if GAF=""
SET GAF=-1
+5 SET $PIECE(GAFR,"|",1)=$SELECT(+GAF:"New GAF Required",1:"No new GAF required")
+6 ;S $P(GAFR,"|",2)=$P(GAF,U,2) ;alb/sat 658 removed 4 lines
+7 ;S $P(GAFR,"|",3)=$$FMTE^XLFDT($P(GAF,U,3))
+8 ;S $P(GAFR,"|",4)=$P(GAF,U,4)
+9 ;S $P(GAFR,"|",5)=$P($G(^VA(200,+$P(GAF,U,4),0)),U,1)
+10 QUIT GAFR
+11 ;
ETH(DFN,PETH,PETHN) ;get ethnicity list
+1 ;INPUT:
+2 ; DFN = Patient ID pointer to PATIENT file
+3 ;RETURN:
+4 ; PETH - Patient Ethnicity list separated by pipe |
+5 ; Pointer to ETHNICITY file 10.2
+6 ; PETHN - Patient Ethnicity names separated by pipe |
+7 NEW SDI,SDID
+8 SET (PETH,PETHN)=""
+9 SET SDI=0
FOR
SET SDI=$ORDER(^DPT(DFN,.06,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+10 SET SDID=$PIECE($GET(^DPT(DFN,.06,SDI,0)),U,1)
+11 SET PETH=$SELECT(PETH'="":PETH_"|",1:"")_SDID
+12 SET PETHN=$SELECT(PETHN'="":PETHN_"|",1:"")_$PIECE($GET(^DIC(10.2,SDID,0)),U,1)
End DoDot:1
+13 QUIT
RACELST(DFN,RACEIEN,RACENAM) ;get list of race information for given patient
+1 ;INPUT:
+2 ; DFN = Patient ID pointer to PATIENT file
+3 ;RETURN:
+4 ; RACEIEN - Patient race list separated by pipe |
+5 ; Pointer to RACE file 10
+6 ; RACENAM - Patient race names separated by pipe |
+7 NEW SDI,SDID
+8 SET (RACEIEN,RACENAM)=""
+9 SET SDI=0
FOR
SET SDI=$ORDER(^DPT(DFN,.02,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+10 SET SDID=$PIECE($GET(^DPT(DFN,.02,SDI,0)),U,1)
+11 SET RACEIEN=$SELECT(RACEIEN'="":RACEIEN_"|",1:"")_SDID
+12 SET RACENAM=$SELECT(RACENAM'="":RACENAM_"|",1:"")_$PIECE($GET(^DIC(10,SDID,0)),U,1)
End DoDot:1
+13 QUIT
