source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPTP3.m@ 1203

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

initial load of FOIAVistA 6/30/08 version

File size: 3.9 KB
Line 
1SCRPTP3 ;ALB/CMM - List of Team's Patients ; 29 Jun 99 04:11PM
2 ;;5.3;Scheduling;**41,48,98,177,231,433,526,520**;AUG 13, 1993;Build 26
3 ;;DMR BP-OIFO Patch SD*5.3*526
4 ;
5 ;List of Team's Patients Report
6 ;
7HITS(ARRY,TIEN) ;
8 ;ARRY - list of patients for a given team
9 ;TIEN - team ien
10 ;
11 N PTIEN,PIEN,PTNAME,PNAME,PTAI,NXT,NODE,CIEN,CNAME,INAME,INST,LAST,NEXT
12 N PAIEN,PC,PHONE,PNODE,PTPA,PTPAN,ROL,PID,TINFO,TNAME,TPIEN,TPNODE
13 N CNT,TPA,FLAG,DFN,VA,VAERR,PCAP,ROLN
14 S INACTIVE=0
15 S NXT=0
16 F S NXT=$O(@ARRY@(NXT)) Q:NXT=""!(NXT'?.N) D
17 .S NODE=$G(@ARRY@(NXT))
18 .Q:NODE=""
19 .S PTIEN=+$P(NODE,"^") ;patient ien
20 .S PTNAME=$P(NODE,"^",2) ;patient name
21 .S PTAI=+$P(NODE,"^",3) ;patient team assignment ien (#404.42)
22 .;
23 .S PNODE=$G(^DPT(PTIEN,0))
24 .Q:PNODE=""
25 .S DFN=PTIEN
26 .D PID^VADPT6
27 .;S PID=VA("BID")
28 .S PID=$E(VA("PID"),1,3)_$E(VA("PID"),5,6)_$E(VA("PID"),8,12)
29 .;
30 .N CNAME,PINF,CLIEN
31 .S CNT=""
32 .F S CNT=$O(^SCPT(404.43,"B",PTAI,CNT)) Q:CNT=""!(CNT'?.N) D
33 ..D TPAR(PTAI,CNT,.PINF,.CNAME,.CLIEN,.PNAME,.ROLN,.PCAP)
34 Q
35 ;
36TPAR(PTAI,START,PINF,CNAME,CLIEN,PNAME,ROLN,PCAP) ;
37 N PTPA,TPIEN,TPNODE,ROL,CIEN,ENROLL,OKAY,NEXT,LAST,PAIEN
38 I '$D(^SCPT(404.43,"B",PTAI)) Q "0^[Not Assigned]"
39 ; ^ no patient team position assignment
40 IF START="" D
41 .S PTPA=$O(^SCPT(404.43,"B",PTAI,START))
42 ELSE D
43 .S PTPA=START
44 I PTPA="" Q "0^[Not Assigned]"
45 S PTPAN=$G(^SCPT(404.43,PTPA,0)) ;patient team assignment
46 I PTPAN=""!(PTPAN=0) Q "0^[Not Assigned]"
47 I $P(PTPAN,"^",4)'="",$P(PTPAN,"^",4)<DT Q -1
48 S TPIEN=+$P(PTPAN,"^",2) ;team position ien (#404.57)
49 I '$D(^SCTM(404.57,TPIEN,0)) Q "0^[Not Assigned]"
50 S TPNODE=$G(^SCTM(404.57,TPIEN,0))
51 I TPNODE="" Q "0^[Not Assigned]"
52 S ROL=+$P(TPNODE,"^",3) ;role for position (ien)
53 Q:'$D(ROLE(ROL))&(ROLE'=1) -1
54 ; ^ not a selected role
55 S ROLN=$P($G(^SD(403.46,ROL,0)),U) ;role name
56 ;
57 S PCAP=$S($P(PTPAN,U,5)<1:"NPC",+$$OKPREC3^SCMCLK(TPIEN,DT)>0:" AP",1:"PCP") ;PC?
58 ;
59 D SETASCL^SCRPRAC2(TPIEN,.CNAME,.CLIEN)
60 ;next two lines commented off - SD*5.3*433
61 ;S ENROLL=$$ENRL(PTIEN,CIEN) ;enrolled in associated clinic
62 ;I 'ENROLL S CNAME="",CIEN=0
63 ;
64 S PAIEN=$$CHK(TPIEN)
65 I +PAIEN'=0 S PIEN=+PAIEN,PNAME=$P(PAIEN,"^",2) ; practitioner's name
66 ;SD*5.3*231
67 I +PAIEN=0 S PIEN=0,PNAME="[Inactive Position]"
68 ;
69 D GETPINF^SCRPPAT2(PTIEN,.CLIEN,.PINF) ;get patient info
70 S CNAME=$G(CNAME(0))
71 S PINF=$G(PINF(0))
72 I PINF="" D
73 .S PINF=PIEN_"^"_$$PDATA^SCRPEC(PIEN,CNAME,CNAME,1)
74 I INACTIVE S @STORE@(INS,TIEN,"INACT")=""
75 S FLAG="Y"
76 S TINFO=$$TINF^SCRPTP(TIEN) ;team information
77 S INST=+$P(TINFO,"^") ;institution ien
78 S INAME=$P($G(^DIC(4,INST,0)),"^") ;institution name
79 S PHONE=$P(TINFO,"^",4) ;team phone
80 S PC=$P(TINFO,"^",3) ;primary care?
81 S TNAME=$P(TINFO,"^",2) ;team name
82 D TFORMAT^SCRPTP2(INST,INAME,TIEN,TNAME,PHONE,PC)
83 D FORMAT^SCRPTP(INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,PINF,ROLN,PCAP)
84 N SCCNT
85 S SCCNT=0 F S SCCNT=$O(CNAME(SCCNT)) Q:SCCNT="" D FORMATAC^SCRPTP(SCCNT,CNAME(SCCNT),PINF(SCCNT),INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,ROLN,PCAP)
86 Q
87 ;
88ENRL(PTIEN,CLIEN) ;FUNCTIONALITY DISABLED
89 ;
90 ;N FOUND,ENODE,EN,NXT
91 ;S FOUND=0
92 ;Q:'$D(^DPT(PTIEN,"DE","B",CLIEN)) FOUND
93 ;S EN=$O(^DPT(PTIEN,"DE","B",CLIEN,""))
94 ;Q:EN=""!'$D(^DPT(PTIEN,"DE",EN,1)) FOUND
95 ;S NXT=""
96 ;F S NXT=$O(^DPT(PTIEN,"DE",EN,1,NXT)) Q:(FOUND)!(NXT="")!(NXT'?.N) D
97 ;check if active enrollment
98 ;S ENODE=$G(^DPT(PTIEN,"DE",EN,1,NXT,0))
99 ;I $P(ENODE,"^",3)'="",$P(ENODE,"^",3)<DT+1!$P(ENODE,"^")>DT Q ;not active enrollment
100 ;; ^ discharge date ^ enrollment date
101 S FOUND=0
102 Q FOUND
103 ;
104CHK(TPIEN) ;assigned to a position
105 ;TPIEN - ien of 404.57 Team Position file
106 ;returns: ien of 200 New Person file
107 N EN,PLIST,PERR,ERR,NAME
108 S PLIST="PLST",PERR="PRR"
109 K @PLIST,@PERR
110 S ERR=$$PRTP^SCAPMC8(TPIEN,,.PLIST,.PERR)
111 I '$D(@PERR) D
112 .S EN=$P($G(@PLIST@(1)),"^") ;ien of new person file
113 .S NAME=$P($G(@PLIST@(1)),"^",2) ; new person name
114 K @PLIST,@PERR
115 Q EN_"^"_NAME
116 ;
Note: See TracBrowser for help on using the repository browser.