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