SCAPMCU4 ;ALB/REW - TEAM API UTILITIES ; 30 Mar 96
;;5.3;Scheduling;**41**;AUG 13, 1993
;;1.0
RESTPT(DFN,SCDATE,SCRPA) ;is pt a restricted consult pt?
; DFN - ien to PATIENT File
; SCATE - Date of interest - default=DT
; SCRPA - literal value of desired restrict patients array
; e.g. scrpa=xx results in xx(sctm)=teamname
; Returned: [1 if yes, 0 if no, -1 if error]
;
N SCRPDTS,SCOK,SCRPLIST,SCRPERR,SCTM,SCTP,SCYES,SCTMNM,SCNDX,SCND
S SCYES=0
S SCRPDTS("BEGIN")=SCDATE
S SCRPDTS("END")=SCDATE
S SCRPDTS("INCL")=0
S SCOK=$$TMPT^SCAPMC(DFN,"SCRPDTS",,"SCRPLIST","SCRPERR")
IF $G(SCRPLIST(0)) D
.F SCNDX=1:1:+$G(SCRPLIST(0)) D
..S SCND=SCRPLIST(SCNDX)
..S SCTM=+SCND
..S SCTMNM=$P(SCND,U,2)
..S SCPTTM=$P(SCND,U,3)
..; restrict from 404.51 (TEAM) file entry??
..IF $P($G(^SCTM(404.51,+SCTM,0)),U,13) D
...S SCYES=1
...S:$L(SCTMNM) @SCRPA@(SCTM)=SCTMNM
..; restring from 404.42 (PATIENT TEAM) file entry??
..IF $P($G(^SCPT(404.42,+SCPTTM,0)),U,10) D
...S SCYES=1
...S:$L(SCTMNM) @SCRPA@(SCTM)=SCTMNM
Q $S($D(SCRPERR):-1,1:SCYES)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCAPMCU4 1103 printed Dec 13, 2024@02:38:21 Page 2
SCAPMCU4 ;ALB/REW - TEAM API UTILITIES ; 30 Mar 96
+1 ;;5.3;Scheduling;**41**;AUG 13, 1993
+2 ;;1.0
RESTPT(DFN,SCDATE,SCRPA) ;is pt a restricted consult pt?
+1 ; DFN - ien to PATIENT File
+2 ; SCATE - Date of interest - default=DT
+3 ; SCRPA - literal value of desired restrict patients array
+4 ; e.g. scrpa=xx results in xx(sctm)=teamname
+5 ; Returned: [1 if yes, 0 if no, -1 if error]
+6 ;
+7 NEW SCRPDTS,SCOK,SCRPLIST,SCRPERR,SCTM,SCTP,SCYES,SCTMNM,SCNDX,SCND
+8 SET SCYES=0
+9 SET SCRPDTS("BEGIN")=SCDATE
+10 SET SCRPDTS("END")=SCDATE
+11 SET SCRPDTS("INCL")=0
+12 SET SCOK=$$TMPT^SCAPMC(DFN,"SCRPDTS",,"SCRPLIST","SCRPERR")
+13 IF $GET(SCRPLIST(0))
Begin DoDot:1
+14 FOR SCNDX=1:1:+$GET(SCRPLIST(0))
Begin DoDot:2
+15 SET SCND=SCRPLIST(SCNDX)
+16 SET SCTM=+SCND
+17 SET SCTMNM=$PIECE(SCND,U,2)
+18 SET SCPTTM=$PIECE(SCND,U,3)
+19 ; restrict from 404.51 (TEAM) file entry??
+20 IF $PIECE($GET(^SCTM(404.51,+SCTM,0)),U,13)
Begin DoDot:3
+21 SET SCYES=1
+22 if $LENGTH(SCTMNM)
SET @SCRPA@(SCTM)=SCTMNM
End DoDot:3
+23 ; restring from 404.42 (PATIENT TEAM) file entry??
+24 IF $PIECE($GET(^SCPT(404.42,+SCPTTM,0)),U,10)
Begin DoDot:3
+25 SET SCYES=1
+26 if $LENGTH(SCTMNM)
SET @SCRPA@(SCTM)=SCTMNM
End DoDot:3
End DoDot:2
End DoDot:1
+27 QUIT $SELECT($DATA(SCRPERR):-1,1:SCYES)
