- 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 Feb 19, 2025@00:07:46 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