source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTA2.m@ 1078

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

revised back to 6/30/08 version

File size: 5.4 KB
Line 
1SCRPTA2 ;ALB/CMM - Patient Listing w/Team Assignment Data ; 30 Jun 99 1:33 PM
2 ;;5.3;Scheduling;**41,88,140,148,174,181,177**;AUG 13, 1993
3 ;
4 ;Patient Listing w/Team Assignment Data Report continued
5 ;
6CHK(PTIEN,PIEN) ;assigned to a position
7 ;PTIEN - ien of 404.42 Patient Team Assignment file
8 ;PIEN - ien of patient file #2
9 ;
10 N NODE,START,TPIEN,TPNODE,ROL,PRAC,ROLN,PCAP,PRCN
11 S START=""
12 Q:'$D(^SCPT(404.43,"B",PTIEN))&(PRACT'="")
13 I '$D(^SCPT(404.43,"B",PTIEN))&(PRACT="") D NOTA(PTIEN,PIEN) Q
14 F S START=$O(^SCPT(404.43,"B",PTIEN,START)) Q:START="" D
15 .S NODE=$G(^SCPT(404.43,START,0))
16 .Q:NODE=""
17 .Q:($P(NODE,"^",4)'="")&($P(NODE,"^",4)<DT)
18 .; ^ not assigned currently
19 .S PCAP=+$P(NODE,U,5)
20 .S TPIEN=+$P(NODE,"^",2) ;team position ien (404.57)
21 .I '$D(^SCTM(404.57,TPIEN,0)) D NOTA(PTIEN,PIEN) Q
22 .S TPNODE=$G(^SCTM(404.57,TPIEN,0))
23 .I TPNODE="" D NOTA(PTIEN,PIEN) Q
24 .S PCAP=$S('PCAP:"NPC",+$$OKPREC3^SCMCLK(TPIEN,DT)>0:" AP",1:"PCP") ; PC?
25 .S PRCN=$P($$OKPREC2^SCMCLK(TPIEN,DT),U,2) ;preceptor name
26 .;
27 .S ROL=+$P(TPNODE,"^",3) ;role for position (ien)
28 .Q:'$D(ROLE(ROL))&(ROLE'=1) ;not a selected role
29 .S ROLN=$P($G(^SD(403.46,ROL,0)),U) ;role name
30 .;
31 .S PRAC=$$PRACI(TPIEN) ;practitioner information
32 .I +PRAC=-1 D NOTA(PTIEN,PIEN) Q
33 .I (PRACT'=1)&('$D(PRACT(+PRAC)))&(+PRAC'=0) Q
34 .; ^ not a selected practitioner
35 .;
36 .S POS=$P($G(^SCTM(404.57,TPIEN,0)),"^")
37 .D FOUND2(START,NODE,TPIEN,POS,TPNODE,PRAC,PIEN,ROLN,PCAP,PRCN)
38 Q
39PRACI(TPIEN) ;
40 ;TPIEN - team position ien (404.57)
41 ;
42 N EN,TPLIST,TPERR,NAME,POS,ERR,NPIEN,NODE,POSIEN
43 S TPLIST="TPLST",TPERR="ERR2"
44 K @TPLIST,@TPERR
45 S ERR=$$PRTP^SCAPMC8(TPIEN,,.TPLIST,.TPERR)
46 Q:ERR=0!($D(@TPERR)) -1
47 S NODE=$G(@TPLIST@(1))
48 Q:NODE="" "0^[Not Assigned]"
49 S NAME=$P(NODE,"^",2) ;practitioner name
50 S NPIEN=+$P(NODE,"^") ;practitioner ien
51 S POS=$P(NODE,"^",4) ;position name
52 S POSIEN=+$P(NODE,"^",3) ;position ien
53 I POS="" S POS="[Not Assigned]",POSIEN=0
54 I NAME="" S NAME="[Not Assigned]",NPIEN=0
55 K @TPLIST,@TPERR
56 Q NPIEN_"^"_NAME_"^"_POS_"^"_POSIEN
57 ;
58FOUND2(START,NODE,TPIEN,POS,TPNODE,PRAC,PIEN,ROLN,PCAP,PRCN) ;
59 ;START - patient team assignment position ien
60 ;NODE - patient team position assignment node
61 ;TPIEN - team position ien (404.57)
62 ;POS - team position
63 ;TPNODE - team position node (404.57)
64 ;PRAC - practitioner info. NAME IEN^NAME^POS^POSIEN
65 ;ROLN - role name
66 ;PCAP - PC/AP/NPC assignment?
67 ;PRCN - preceptor name
68 ;
69 N PTNAME,PID,ADATE
70 S PTNAME=$P($G(^DPT(PIEN,0)),"^") ;patient name
71 S PID=$P($G(^DPT(PIEN,.36)),"^",3),PID=$TR(PID,"-","")
72 S PID=$E(PID,6,10) ;last four pid include 5th for pseudo notation
73 ;
74 S ADATE=$P(NODE,"^",3) ;position assignment date - fm format
75 ;convert to external format
76 I ADATE'="" S ADATE=$TR($$FMTE^XLFDT(ADATE,"5DF")," ","0")
77 ;
78 S PNAME=$P(PRAC,"^",2) ;practitioner name
79 S PNIEN=$P(PRAC,"^") ;practitioner ien
80 ;
81 S TIEN=+$P(TPNODE,"^",2) ;ien team file 404.51
82 S TMN=$G(^SCTM(404.51,TIEN,0))
83 Q:TMN=""
84 S TNAME=$P(TMN,"^") ;team name
85 S PC=$P(TMN,"^",5) ;primary care team 1/0
86 S IIEN=+$P(TMN,"^",7) ;institution ien
87 S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution
88 ;
89 D FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POS,TPIEN,ADATE,PIEN,ROLN,PCAP,PRCN)
90 Q
91 ;
92FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PIEN,POS,TPIEN,ADATE,PTIEN,ROLN,PCAP,PRCN) ;
93 ;IIEN - institution ien
94 ;INAME - institution name
95 ;TNAME - team name
96 ;TIEN - team ien
97 ;PC - primary care 1/0
98 ;PTNAME - patient name
99 ;PID - last 4 pid plus 5th pseudo
100 ;PNAME - practitioner name
101 ;PIEN - practitioner ien
102 ;POS - position name
103 ;TPIEN - position ien
104 ;ADATE - assignment date
105 ;PTIEN - patient ien
106 ;ROLN - role name
107 ;PCAP - PC/AP/NPC assignment?
108 ;PRCN - preceptor name
109 ;
110 I INAME="" S INAME="[BAD DATA]"
111 I TNAME="" S TNAME="[BAD DATA]"
112 I PNAME="" S PNAME="[BAD DATA]"
113 I '$D(@STORE@("I",INAME,IIEN)) S @STORE@("I",INAME,IIEN)=""
114 I '$D(@STORE@("T",IIEN,TNAME,TIEN)) S @STORE@("T",IIEN,TNAME,TIEN)=""
115 I '$D(@STORE@("P",IIEN,TIEN,PNAME,PIEN,TPIEN)) S @STORE@("P",IIEN,TIEN,PNAME,PIEN,TPIEN)=""
116 S @STORE@(IIEN)="Division: "_INAME
117 S @STORE@(IIEN,TIEN)="Team: "_TNAME
118 S $E(@STORE@(IIEN,TIEN),40)="Primary Care Team: "_$S(PC=1:"YES",1:"NO")
119 ;
120 S @STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN)=$E(PTNAME,1,21)
121 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),24)=PID
122 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),31)=ADATE
123 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),43)=PCAP
124 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),49)=$E(PNAME,1,21)
125 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),70)=$E(POS,1,20)
126 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),92)=$E(ROLN,1,20)
127 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),113)=$E(PRCN,1,20)
128 Q
129 ;
130NOTA(PTIEN,PIEN) ;
131 ;PTIEN - patient team assignment (#404.42)
132 ;PIEN - patient ien
133 N IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POSIEN,POS,TPIEN
134 N ROLN,PCAP,PRCN,ADATE
135 S POS="[Not Assigned]",POSIEN=0
136 S PNAME="[Not Assigned]",PNIEN=0
137 S (ROLN,PCAP,PRCN,ADATE)=""
138 ;
139 S PTNAME=$E($P($G(^DPT(PIEN,0)),"^"),1,20) ;patient name
140 S PID=$P($G(^DPT(PIEN,.36)),"^",3),PID=$TR(PID,"-","")
141 S PID=$E(PID,6,10) ;last 4 plus 5th for psuedo
142 ;
143 S TIEN=+$P($G(^SCPT(404.42,PTIEN,0)),"^",3) ;team ien
144 S TMN=$G(^SCTM(404.51,TIEN,0))
145 Q:TMN=""
146 S TNAME=$P(TMN,"^") ;team name
147 S PC=$P(TMN,"^",5) ;primary care team 1/0
148 S IIEN=+$P(TMN,"^",7) ;institution ien
149 S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution name
150 ;
151 D FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POS,POSIEN,ADATE,PIEN,ROLN,PCAP,PRCN)
152 Q
Note: See TracBrowser for help on using the repository browser.