SCMCDD2.m

SCMCDD2 ;ALB/REW - DD Calls used by PCMM ; 27 March 1996

 ;;5.3;Scheduling;**41,107,520**;AUG 13, 1993;Build 26

 ;1

USEPCDEF(SCCL) ;how should pc practitioner be used for clinic

 ; return 2=always default 1=default if no provider listed 0 -never

 Q 2

SETSCTM(SCTP,SCCL,SCTMNM) ;create 'TEAM' x-ref for Hospital Location File (#44)

 ; x=sccl, da=sctp sctmnm=name of team

 Q:'$G(SCTP)!('$G(SCCL))

 S SCTMNM=$G(SCTMNM,$P(^SCTM(404.51,+$P(^SCTM(404.57,SCTP,0),U,2),0),U))

 S:$L(SCTMNM) ^SC("TEAM",SCTMNM,+SCCL)=""

 Q

 ;

KILLSCTM(SCTP,SCCL,SCTMNM) ;kill 'TEAM' x-ref for File #44 (if no other positions from team have this as associated clinic)

 ; x=sccl, da=sctp sctmnm=name of team

 N SCTM

 Q:'$G(SCTP)!('$G(SCCL))

 S SCTM=+$P(^SCTM(404.57,SCTP,0),U,2)

 S SCTMNM=$G(SCTMNM,$P(^SCTM(404.51,+SCTM,0),U))

 K:$L(SCTMNM)&('$$OKTMCL(SCTM,SCTP,SCCL)) ^SC("TEAM",SCTMNM,+SCCL)

 Q

OKTMCL(SCTM,SCTP,SCCL) ;does team have another position with this clinic as an assoicated clinic?

 N SCXTP,SCOK

 S SCOK=0

 S SCXTP=0

 F  S SCXTP=$O(^SCTM(404.57,"E",SCCL,SCXTP)) Q:('SCXTP)!(SCXTP=SCTP)  D

 .I $P(^SCTM(404.57,SCXTP,0),U,2)'=SCTM Q

 .S SCOK=1

 Q SCOK

STSCTMNM(SCTM,SCTMNM) ;if team name changes - set for 'TEAM' xrefs for file#44

 ; sctm=da sctmnm=x

 Q:'$G(SCTM)!(SCTMNM="")

 N SCTPNM,SCCL

 S SCTPNM=""

 F  S SCTPNM=$O(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM)) Q:SCTPNM=""  D

 .S SCTP=$O(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM,0)) ;note: name is unique

 .S SCCL=$P($G(^SCTM(404.57,+SCTP,0)),U,9)

 .D:SCCL SETSCTM(SCTP,SCCL,SCTMNM)

 Q

KLSCTMNM(SCTM,SCTMNM) ;if team name changes - kill 'TEAM' xrefs for file #44

 ; sctm=da sctmnm=x

 Q:'$G(SCTM)!(SCTMNM="")

 N SCTPNM,SCCL

 S SCTPNM=""

 F  S SCTPNM=$O(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM)) Q:SCTPNM=""  D

 .S SCTP=$O(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM,0)) ;note: name is unique

 .S SCCL=$P($G(^SCTM(404.57,+SCTP,0)),U,9)

 .K:SCCL ^SC("TEAM",SCTMNM)

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---SCMCDD2   1919     printed  Mar 13, 2025@21:45:02                                                                                                                                                                                                     Page 2

SCMCDD2   ;ALB/REW - DD Calls used by PCMM ; 27 March 1996

 +1       ;;5.3;Scheduling;**41,107,520**;AUG 13, 1993;Build 26

 +2       ;1

USEPCDEF(SCCL) ;how should pc practitioner be used for clinic

 +1       ; return 2=always default 1=default if no provider listed 0 -never

 +2        QUIT 2

SETSCTM(SCTP,SCCL,SCTMNM) ;create 'TEAM' x-ref for Hospital Location File (#44)

 +1       ; x=sccl, da=sctp sctmnm=name of team

 +2        if '$GET(SCTP)!('$GET(SCCL))

               QUIT 

 +3        SET SCTMNM=$GET(SCTMNM,$PIECE(^SCTM(404.51,+$PIECE(^SCTM(404.57,SCTP,0),U,2),0),U))

 +4        if $LENGTH(SCTMNM)

               SET ^SC("TEAM",SCTMNM,+SCCL)=""

 +5        QUIT 

 +6       ;

KILLSCTM(SCTP,SCCL,SCTMNM) ;kill 'TEAM' x-ref for File #44 (if no other positions from team have this as associated clinic)

 +1       ; x=sccl, da=sctp sctmnm=name of team

 +2        NEW SCTM

 +3        if '$GET(SCTP)!('$GET(SCCL))

               QUIT 

 +4        SET SCTM=+$PIECE(^SCTM(404.57,SCTP,0),U,2)

 +5        SET SCTMNM=$GET(SCTMNM,$PIECE(^SCTM(404.51,+SCTM,0),U))

 +6        if $LENGTH(SCTMNM)&('$$OKTMCL(SCTM,SCTP,SCCL))

               KILL ^SC("TEAM",SCTMNM,+SCCL)

 +7        QUIT 

OKTMCL(SCTM,SCTP,SCCL) ;does team have another position with this clinic as an assoicated clinic?

 +1        NEW SCXTP,SCOK

 +2        SET SCOK=0

 +3        SET SCXTP=0

 +4        FOR 

               SET SCXTP=$ORDER(^SCTM(404.57,"E",SCCL,SCXTP))

               if ('SCXTP)!(SCXTP=SCTP)

                   QUIT 

               Begin DoDot:1

 +5                IF $PIECE(^SCTM(404.57,SCXTP,0),U,2)'=SCTM

                       QUIT 

 +6                SET SCOK=1

               End DoDot:1

 +7        QUIT SCOK

STSCTMNM(SCTM,SCTMNM) ;if team name changes - set for 'TEAM' xrefs for file#44

 +1       ; sctm=da sctmnm=x

 +2        if '$GET(SCTM)!(SCTMNM="")

               QUIT 

 +3        NEW SCTPNM,SCCL

 +4        SET SCTPNM=""

 +5        FOR 

               SET SCTPNM=$ORDER(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM))

               if SCTPNM=""

                   QUIT 

               Begin DoDot:1

 +6       ;note: name is unique

                   SET SCTP=$ORDER(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM,0))

 +7                SET SCCL=$PIECE($GET(^SCTM(404.57,+SCTP,0)),U,9)

 +8                if SCCL

                       DO SETSCTM(SCTP,SCCL,SCTMNM)

               End DoDot:1

 +9        QUIT 

KLSCTMNM(SCTM,SCTMNM) ;if team name changes - kill 'TEAM' xrefs for file #44

 +1       ; sctm=da sctmnm=x

 +2        if '$GET(SCTM)!(SCTMNM="")

               QUIT 

 +3        NEW SCTPNM,SCCL

 +4        SET SCTPNM=""

 +5        FOR 

               SET SCTPNM=$ORDER(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM))

               if SCTPNM=""

                   QUIT 

               Begin DoDot:1

 +6       ;note: name is unique

                   SET SCTP=$ORDER(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM,0))

 +7                SET SCCL=$PIECE($GET(^SCTM(404.57,+SCTP,0)),U,9)

 +8                if SCCL

                       KILL ^SC("TEAM",SCTMNM)

               End DoDot:1

 +9        QUIT