- 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 Feb 19, 2025@00:04:48 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)