source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPSLT2.m@ 1446

Last change on this file since 1446 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 5.7 KB
Line 
1SCRPSLT2 ;ALB/CMM - Summary Listing of Teams Continued ; 9/15/99 10:43am
2 ;;5.3;Scheduling;**41,174,177,231,520**;AUG 13, 1993;Build 26
3 ;
4 ;Summary Listing of Teams Report
5 ;
6KEEP(TNODE,APOS,TPOS,ROL,TM,TPCN,TNPC) ;
7 ;TNODE - zero node of the team position file
8 ;APOS - ien of team position file
9 ;TPOS - ien of position assignment history file
10 ;ROL - ien of role
11 ;TM - ien of team
12 ;
13 N POS,TNAME,TPHONE,TPC,TDIV,TEN,TMN,DIV,PPC,PCLIN,VAE,PRACT,NPC,MAX
14 N PCN,ROLN,PRCTP,PRCPC,PRCNPC,PRCPTE,SCPC,SCNPC,XDAT,SCDT,SCI
15 ;
16 S TEN=+$P(TNODE,"^",2) ;team file pointer
17 S TMN=$G(^SCTM(404.51,TEN,0))
18 S TNAME=$P(TMN,"^") ;team name
19 S DIV=+$P(TMN,"^",7) ;division ien
20 S TDIV=$P($G(^DIC(4,DIV,0)),"^") ;team division
21 D KTEAM(TNAME,TDIV,TM,DIV)
22 ;
23 S POS=$P(TNODE,"^") ;position name
24 ;SD*5.3*231 - call SCMCLK to determine in AP or not
25 S PPC=$S($P(TNODE,"^",4)<1:"NPC",+$$OKPREC3^SCMCLK(APOS,DT)>0:" AP",1:"PCP") ;PC?
26 ;S PCLIN=$P($G(^SC(+$P(TNODE,"^",9),0)),"^") ;associated clinic
27 D SETASCL^SCRPRAC2(APOS,.PCLIN)
28 S PCLIN=$G(PCLIN(0))
29 S ROLN=$P($G(^SD(403.46,+ROL,0)),U) ;role name
30 ;
31 S (PRCPC,PRCNPC)="",SCI="^TMP(""SCRATCH"",$J)"
32 K @SCI
33 S (SCDT("BEGIN"),SCDT("END"))=DT,SCDT("INCL")=0,SCDT="SCDT"
34 S SCI=$$PRECHIS^SCMCLK(APOS,.SCDT,SCI)
35 I SCI=1 S SCI=0 F S SCI=$O(^TMP("SCRATCH",$J,SCI)) Q:'SCI D
36 .N SCPRCD
37 .S SCPRCD=^TMP("SCRATCH",$J,SCI),PRCPTE=$P(SCPRCD,U,3) Q:'PRCPTE
38 .S SCPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,1) ;precepted PC patients
39 .S:SCPC<0 SCPC=0 S PRCPC=PRCPC+SCPC
40 .S SCNPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,0) ;all precepted patients
41 .S:SCNPC<0 SCNPC=0 S SCNPC=SCNPC-SCPC S:SCNPC<0 SCNPC=0
42 .S PRCNPC=PRCNPC+SCNPC
43 .Q
44 ;
45 S XDAT=ROLN_U_PRCPC_U_PRCNPC ;extra data
46 ;
47 S VAE=+$P($G(^SCTM(404.52,TPOS,0)),"^",3) ;ien of new person file
48 S PRACT=$P($G(^VA(200,VAE,0)),"^") ;practitioner name
49 I PRACT="" S PRACT="[Not Assigned]"
50 ;
51 S MAX=+$P(TNODE,"^",8) I MAX<0 S MAX=0
52 S PCN=$$PCPOSCNT^SCAPMCU1(APOS,DT) S:PCN=-1 PCN=0
53 S TPCN(TM)=$G(TPCN(TM))+PCN
54 S NPC=$$PCPOSCNT^SCAPMCU1(APOS,DT,0) S:NPC=-1 NPC=0
55 S NPC=NPC-PCN S:NPC<0 NPC=0
56 S TNPC(TM)=$G(TNPC(TM))+NPC
57 ;
58 D FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MAX,PCN,XDAT)
59 N SCAC
60 S SCAC=0
61 F S SCAC=$O(PCLIN(SCAC)) Q:SCAC="" D FORMATAC(APOS,POS,PCLIN(SCAC),VAE,DIV,TM)
62 Q
63 ;
64TEAMT(TM,TPASS,TMAX,TPCN,TOA,TNPC) ;
65 ;set team totals into global
66 S @STORE@("TOTALS",TM,"H1")=" Team Totals:"
67 S @STORE@("TOTALS",TM,"H2")="------------------------------------"
68 S @STORE@("TOTALS",TM,"H3")=" Primary Care Assignments: "_$J($G(TPCN(TM)),6,0)
69 S @STORE@("TOTALS",TM,"H4")=" Non-PC Assignments: "_$J($G(TNPC(TM)),6,0)
70 S @STORE@("TOTALS",TM,"H5")=" Unique Patients Assigned: "_$J($G(TPASS(TM)),6,0)
71 S @STORE@("TOTALS",TM,"H6")=" Maximum Patients Allowed: "_$J($G(TMAX(TM)),6,0)
72 S @STORE@("TOTALS",TM,"H7")=" Total Open Assignments: "_$J($G(TOA(TM)),6,0)
73 Q
74 ;
75FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MX,PC,XDAT) ;
76 ;
77 NEW TMP
78 I PRACT="" S PRACT="Bad Data"
79 S @STORE@("PN",DIV,TM,PRACT,VAE)=""
80 S @STORE@(DIV,TM,VAE,APOS)=$E(PRACT,1,20) ;practitioner name
81 S $E(@STORE@(DIV,TM,VAE,APOS),23)=$E(POS,1,20) ;position
82 S $E(@STORE@(DIV,TM,VAE,APOS),45)=PPC ;PC?
83 S $E(@STORE@(DIV,TM,VAE,APOS),50)=$E($P(XDAT,U),1,20) ;role
84 S $E(@STORE@(DIV,TM,VAE,APOS),72)=$E(PCLIN,1,25) ;assoc. clinic
85 S $E(@STORE@(DIV,TM,VAE,APOS),99)=$J(MX,6,0) ;max pts.
86 S $E(@STORE@(DIV,TM,VAE,APOS),107)=$J(PC,5,0) ;PC pts.
87 S $E(@STORE@(DIV,TM,VAE,APOS),114)=$J(NPC,5,0) ;non-PC pts.
88 ;
89 ;bp/djb 'Precepted Patients' column should be zero for APs.
90 ;Old code begins
91 ;S $E(@STORE@(DIV,TM,VAE,APOS),121)=$J($P(XDAT,U,2),5,0) ;precept PC
92 ;S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J($P(XDAT,U,3),5,0) ;precept NPC
93 ;Old code ends
94 ;New code begins
95 S (TMP(1),TMP(2))=0 I PPC'["AP" D ;APs should be zero
96 .S TMP(1)=$P(XDAT,U,2)
97 .S TMP(2)=$P(XDAT,U,3)
98 S $E(@STORE@(DIV,TM,VAE,APOS),121)=$J(TMP(1),5,0) ;precepted PC
99 S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J(TMP(2),5,0) ;precepted NPC
100 ;New code ends
101 Q
102FORMATAC(APOS,POS,PCLIN,VAE,DIV,TM) ;clinic multiples
103 S $E(@STORE@(DIV,TM,VAE,APOS,SCAC),72)=$E(PCLIN,1,30)
104 Q
105 ;
106TOTAL(INST,TEM) ;
107 ;Prints team totals
108 N NXT
109 S NXT=""
110 W !
111 F S NXT=$O(@STORE@("TOTALS",TEM,NXT)) Q:NXT="" D
112 .;bp/djb Stop displaying certain 'Team Totals:' lines.
113 .;New code begin
114 .Q:$G(@STORE@("TOTALS",TEM,NXT))["Unique Patients Assigned"
115 .Q:$G(@STORE@("TOTALS",TEM,NXT))["Maximum Patients Allowed"
116 .Q:$G(@STORE@("TOTALS",TEM,NXT))["Total Open Assignments"
117 .;New code end
118 .W !,$G(@STORE@("TOTALS",TEM,NXT))
119 W !
120 Q
121 ;
122KTEAM(TNAME,TDIV,TIEN,IEND) ;
123 ;store team information
124 I TNAME="" S TNAME="[BAD DATA]"
125 I TDIV="" S TDIV="[BAD DATA]"
126 S @STORE@("I",TDIV,IEND)=""
127 S @STORE@("T",IEND,TNAME,TIEN)=""
128 S @STORE@(IEND)=" Division: "_TDIV
129 S @STORE@(IEND,TIEN)="Team Name: "_TNAME
130 Q
131 ;
132FORHEAD ;
133 S @STORE@("H3")="Practitioner"
134 S $E(@STORE@("H3"),23)="Position"
135 S $E(@STORE@("H3"),45)="PC?"
136 S $E(@STORE@("H3"),50)="Standard Role"
137 S $E(@STORE@("H3"),72)="Associated Clinic"
138 S $E(@STORE@("H1"),101)="Max."
139 S $E(@STORE@("H2"),101)="Pts."
140 S $E(@STORE@("H3"),99)="Allow."
141 S $E(@STORE@("H1"),107)="--Assigned--"
142 S $E(@STORE@("H2"),107)="--Patients--"
143 S $E(@STORE@("H3"),107)="PC NonPC"
144 S $E(@STORE@("H1"),121)="--Precepted-"
145 S $E(@STORE@("H2"),121)="--Patients--"
146 S $E(@STORE@("H3"),121)="PC NonPC"
147 S $P(@STORE@("H4"),"=",133)=""
148 Q
149HEADER(INST,TEM,TEND) ;
150 N NXT
151 S NXT="H",TEND=$G(TEND)
152 W !!,@STORE@(INST)
153 W !!,@STORE@(INST,TEM)
154 I 'TEND F S NXT=$O(@STORE@(NXT)) Q:NXT'?1"H".E D
155 .W !,@STORE@(NXT)
156 W !
157 Q
158NEWP(INST,TEM,TITL,PAGE,TEND) ;
159 S TEND=$G(TEND)
160 D NEWP1^SCRPU3(.PAGE,TITL)
161 I STOP Q
162 D HEADER(INST,TEM,TEND)
163 Q
164HOLD1(PAGE,TITL,INST,TEM,TEND) ;
165 ;device is home, reached end of page
166 S TEND=$G(TEND)
167 D HOLD^SCRPU3(.PAGE,TITL)
168 I STOP Q
169 D HEADER(INST,TEM,TEND)
170 Q
Note: See TracBrowser for help on using the repository browser.