SCMCRT1 ;ALB/SCK - TEAM PROFILE REPORT ; 10/30/95
;;5.3;Scheduling;**41**;AUG 13, 1993
;;1T1;Primary Care Management Module
;
; Routine for collecting Team information for the
; Team Profile report
;
START(SCTS,SCPS,SCTEAMS,SCBRK) ;
; SCTS = Team Status
; SCPS = Positon status
; SCBRK = Page break as team changes
;
; Status values:
; 1 Show active only
; 0 Show inactive only
; -1 Show all
; 10 Selected Teams
;
; SCTEAMS = List of teams to print
;
N SCTM,SCTMIEN,SCI,SCDTRNG,SCERMSG,SCRTN
K ^TMP("PCMTP")
S SCDTRNG=""
;
IF $G(SCTS)=10,$G(SCTEAMS)=0 D G CONT
. S SCTM=""
. F S SCTM=$O(SCTEAMS(SCTM)) Q:SCTM="" D
.. D BLD(SCTM)
;
S SCTM=""
F S SCTM=$O(^SCTM(404.51,"B",SCTM)) Q:SCTM="" D
. S SCTMIEN="",SCTMIEN=$O(^SCTM(404.51,"B",SCTM,SCTMIEN))
. Q:'$$TEAMOK(SCTS,SCTMIEN)
. D BLD(SCTMIEN)
;
CONT ;
D TMRPT^SCMCRT1A(SCBRK)
Q
;
TEAMOK(SCACT,SCIEN) ; function to check teams current status against
; the requested status
;
; SCACT - See status values above
; SCIEN - IEN value for the team in 404.51
;
; Returns 0 if team does not meet requested status,
; 1 if team does meet the requested status.
;
;
N SCRTN,SCOK,SCER
S SCOK=1
G:SCACT<0 TEAMOKQ
IF '+$$ACTHIST^SCAPMCU1(404.58,SCIEN,"SCDTRNG","SCER") S SCOK=0
TEAMOKQ Q (SCOK)
;
POSTOK(SCPACT,SCIEN) ; function to check a positions current status against
; against the requested status
;
; SCPACT - See status values above
; SCIEN - Ien value for the position in the 404.57 file
;
; Returns 0 if position does not meet requested status
; 1 if position does meet the status
;
N SCOK,SCER
S SCOK=1
G:SCPACT<0 POSTOKQ
IF '+$$ACTHIST^SCAPMCU1(404.59,SCIEN,"SCDTRNG","SCER") S SCOK=0
POSTOKQ Q (SCOK)
;
BLD(SCIEN) ; Build entry for the team profile in ^TMP("PCMTP",$J)
;
; Team information is on the zero node. The format is the same
; as for the zero node in file #404.51
;
; The team description (WP field nodes) are on the "D" node.
; The teams positions are on individual "P" nodes, by name.
; Format is position ien^standard role (external)^primary care^
; max patients allowed^active status.
;
N SCTNODE,II,SCPNODE,SCPIEN
S SCTNODE=$G(^SCTM(404.51,SCIEN,0))
Q:$D(SCTNODE)=0
;
; Loop thru all the teams in file 404.51 and build the zero node
; for the requested teams
;
S ^TMP("PCMTP",$J,SCIEN,0)=SCTNODE
IF $D(^SCTM(404.51,SCIEN,"D")) D
. S II=0
. F S II=$O(^SCTM(404.51,SCIEN,"D",II)) Q:II="" D
.. S ^TMP("PCMTP",$J,SCIEN,"D",II)=$G(^SCTM(404.51,SCIEN,"D",II,0))
;
; For each team, loop thru all the team positions, and build
; nodes for each position that matches the requested status
;
S SCPIEN=""
F S SCPIEN=$O(^SCTM(404.57,"C",SCIEN,SCPIEN)) Q:SCPIEN="" D
. Q:'$$POSTOK(SCPS,SCPIEN)
. S SCPNODE=$G(^SCTM(404.57,SCPIEN,0))
. S ^TMP("PCMTP",$J,SCIEN,"P",$P(SCPNODE,U))=SCPIEN_"^"_$$ROLE($P(SCPNODE,U,3))_"^"_$$CARE($P(SCPNODE,U,4))_"^"_+$P(SCPNODE,U,8)_"^"_$$ACTPOS(SCPIEN)
;
IF $D(^TMP("PCMTP",$J,SCIEN,"P"))=0 S ^TMP("PCMTP",$J,SCIEN,"P","NO POSITIONS")=""
Q
;
ACTPOS(SCIEN) ; Returns the active status of the position for the
; date range of the report.
;
N SCSTAT,SCER
S SCTAT=$$ACTHIST^SCAPMCU1(404.59,SCIEN,"SCDTRNG","SCER")
Q +SCTAT
;
ROLE(SCIEN) ; Returns the standard role for a position in external format
;
N SCROLE
S SCROLE="NO STANDARD ROLE"
G:$G(SCIEN)="" ROLEQ
S SCROLE=$P($G(^SD(403.46,SCIEN,0)),U)
ROLEQ Q SCROLE
;
CARE(SCC) ; Returns Yes if the position can provide primary care, No
; if the position cannot.
;
N STAT
S STAT="NO"
S:SCC=1 STAT="YES"
CAREQ Q STAT
;
QSTART ;
D START(SCTMS,SCPOS,.SCTEAMS,SCBRK)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCRT1 3860 printed Apr 09, 2024@21:46:15 Page 2
SCMCRT1 ;ALB/SCK - TEAM PROFILE REPORT ; 10/30/95
+1 ;;5.3;Scheduling;**41**;AUG 13, 1993
+2 ;;1T1;Primary Care Management Module
+3 ;
+4 ; Routine for collecting Team information for the
+5 ; Team Profile report
+6 ;
START(SCTS,SCPS,SCTEAMS,SCBRK) ;
+1 ; SCTS = Team Status
+2 ; SCPS = Positon status
+3 ; SCBRK = Page break as team changes
+4 ;
+5 ; Status values:
+6 ; 1 Show active only
+7 ; 0 Show inactive only
+8 ; -1 Show all
+9 ; 10 Selected Teams
+10 ;
+11 ; SCTEAMS = List of teams to print
+12 ;
+13 NEW SCTM,SCTMIEN,SCI,SCDTRNG,SCERMSG,SCRTN
+14 KILL ^TMP("PCMTP")
+15 SET SCDTRNG=""
+16 ;
+17 IF $GET(SCTS)=10
IF $GET(SCTEAMS)=0
Begin DoDot:1
+18 SET SCTM=""
+19 FOR
SET SCTM=$ORDER(SCTEAMS(SCTM))
if SCTM=""
QUIT
Begin DoDot:2
+20 DO BLD(SCTM)
End DoDot:2
End DoDot:1
GOTO CONT
+21 ;
+22 SET SCTM=""
+23 FOR
SET SCTM=$ORDER(^SCTM(404.51,"B",SCTM))
if SCTM=""
QUIT
Begin DoDot:1
+24 SET SCTMIEN=""
SET SCTMIEN=$ORDER(^SCTM(404.51,"B",SCTM,SCTMIEN))
+25 if '$$TEAMOK(SCTS,SCTMIEN)
QUIT
+26 DO BLD(SCTMIEN)
End DoDot:1
+27 ;
CONT ;
+1 DO TMRPT^SCMCRT1A(SCBRK)
+2 QUIT
+3 ;
TEAMOK(SCACT,SCIEN) ; function to check teams current status against
+1 ; the requested status
+2 ;
+3 ; SCACT - See status values above
+4 ; SCIEN - IEN value for the team in 404.51
+5 ;
+6 ; Returns 0 if team does not meet requested status,
+7 ; 1 if team does meet the requested status.
+8 ;
+9 ;
+10 NEW SCRTN,SCOK,SCER
+11 SET SCOK=1
+12 if SCACT<0
GOTO TEAMOKQ
+13 IF '+$$ACTHIST^SCAPMCU1(404.58,SCIEN,"SCDTRNG","SCER")
SET SCOK=0
TEAMOKQ QUIT (SCOK)
+1 ;
POSTOK(SCPACT,SCIEN) ; function to check a positions current status against
+1 ; against the requested status
+2 ;
+3 ; SCPACT - See status values above
+4 ; SCIEN - Ien value for the position in the 404.57 file
+5 ;
+6 ; Returns 0 if position does not meet requested status
+7 ; 1 if position does meet the status
+8 ;
+9 NEW SCOK,SCER
+10 SET SCOK=1
+11 if SCPACT<0
GOTO POSTOKQ
+12 IF '+$$ACTHIST^SCAPMCU1(404.59,SCIEN,"SCDTRNG","SCER")
SET SCOK=0
POSTOKQ QUIT (SCOK)
+1 ;
BLD(SCIEN) ; Build entry for the team profile in ^TMP("PCMTP",$J)
+1 ;
+2 ; Team information is on the zero node. The format is the same
+3 ; as for the zero node in file #404.51
+4 ;
+5 ; The team description (WP field nodes) are on the "D" node.
+6 ; The teams positions are on individual "P" nodes, by name.
+7 ; Format is position ien^standard role (external)^primary care^
+8 ; max patients allowed^active status.
+9 ;
+10 NEW SCTNODE,II,SCPNODE,SCPIEN
+11 SET SCTNODE=$GET(^SCTM(404.51,SCIEN,0))
+12 if $DATA(SCTNODE)=0
QUIT
+13 ;
+14 ; Loop thru all the teams in file 404.51 and build the zero node
+15 ; for the requested teams
+16 ;
+17 SET ^TMP("PCMTP",$JOB,SCIEN,0)=SCTNODE
+18 IF $DATA(^SCTM(404.51,SCIEN,"D"))
Begin DoDot:1
+19 SET II=0
+20 FOR
SET II=$ORDER(^SCTM(404.51,SCIEN,"D",II))
if II=""
QUIT
Begin DoDot:2
+21 SET ^TMP("PCMTP",$JOB,SCIEN,"D",II)=$GET(^SCTM(404.51,SCIEN,"D",II,0))
End DoDot:2
End DoDot:1
+22 ;
+23 ; For each team, loop thru all the team positions, and build
+24 ; nodes for each position that matches the requested status
+25 ;
+26 SET SCPIEN=""
+27 FOR
SET SCPIEN=$ORDER(^SCTM(404.57,"C",SCIEN,SCPIEN))
if SCPIEN=""
QUIT
Begin DoDot:1
+28 if '$$POSTOK(SCPS,SCPIEN)
QUIT
+29 SET SCPNODE=$GET(^SCTM(404.57,SCPIEN,0))
+30 SET ^TMP("PCMTP",$JOB,SCIEN,"P",$PIECE(SCPNODE,U))=SCPIEN_"^"_$$ROLE($PIECE(SCPNODE,U,3))_"^"_$$CARE($PIECE(SCPNODE,U,4))_"^"_+$PIECE(SCPNODE,U,8)_"^"_$$ACTPOS(SCPIEN)
End DoDot:1
+31 ;
+32 IF $DATA(^TMP("PCMTP",$JOB,SCIEN,"P"))=0
SET ^TMP("PCMTP",$JOB,SCIEN,"P","NO POSITIONS")=""
+33 QUIT
+34 ;
ACTPOS(SCIEN) ; Returns the active status of the position for the
+1 ; date range of the report.
+2 ;
+3 NEW SCSTAT,SCER
+4 SET SCTAT=$$ACTHIST^SCAPMCU1(404.59,SCIEN,"SCDTRNG","SCER")
+5 QUIT +SCTAT
+6 ;
ROLE(SCIEN) ; Returns the standard role for a position in external format
+1 ;
+2 NEW SCROLE
+3 SET SCROLE="NO STANDARD ROLE"
+4 if $GET(SCIEN)=""
GOTO ROLEQ
+5 SET SCROLE=$PIECE($GET(^SD(403.46,SCIEN,0)),U)
ROLEQ QUIT SCROLE
+1 ;
CARE(SCC) ; Returns Yes if the position can provide primary care, No
+1 ; if the position cannot.
+2 ;
+3 NEW STAT
+4 SET STAT="NO"
+5 if SCC=1
SET STAT="YES"
CAREQ QUIT STAT
+1 ;
QSTART ;
+1 DO START(SCTMS,SCPOS,.SCTEAMS,SCBRK)
+2 QUIT
