Changeset 623 for WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTA2.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTA2.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTA2.m
r613 r623 1 SCRPTA2 ;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,526**;AUG 13, 1993;Build 8 3 ; 4 ;Patient Listing w/Team Assignment Data Report continued 5 ; 6 CHK(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 39 PRACI(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 ; 58 FOUND2(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 ;9 digit ssn SD*5.3*526 - dmr 73 ;S PID=$E(PID,6,10) ;last four pid include 5th for pseudo notation 74 ; 75 S ADATE=$P(NODE,"^",3) ;position assignment date - fm format 76 ;convert to external format 77 I ADATE'="" S ADATE=$TR($$FMTE^XLFDT(ADATE,"5DF")," ","0") 78 ; 79 S PNAME=$P(PRAC,"^",2) ;practitioner name 80 S PNIEN=$P(PRAC,"^") ;practitioner ien 81 ; 82 S TIEN=+$P(TPNODE,"^",2) ;ien team file 404.51 83 S TMN=$G(^SCTM(404.51,TIEN,0)) 84 Q:TMN="" 85 S TNAME=$P(TMN,"^") ;team name 86 S PC=$P(TMN,"^",5) ;primary care team 1/0 87 S IIEN=+$P(TMN,"^",7) ;institution ien 88 S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution 89 ; 90 D FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POS,TPIEN,ADATE,PIEN,ROLN,PCAP,PRCN) 91 Q 92 ; 93 FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PIEN,POS,TPIEN,ADATE,PTIEN,ROLN,PCAP,PRCN) ; 94 ;IIEN - institution ien 95 ;INAME - institution name 96 ;TNAME - team name 97 ;TIEN - team ien 98 ;PC - primary care 1/0 99 ;PTNAME - patient name 100 ;PID - last 4 pid plus 5th pseudo 101 ;PNAME - practitioner name 102 ;PIEN - practitioner ien 103 ;POS - position name 104 ;TPIEN - position ien 105 ;ADATE - assignment date 106 ;PTIEN - patient ien 107 ;ROLN - role name 108 ;PCAP - PC/AP/NPC assignment? 109 ;PRCN - preceptor name 110 ; 111 I INAME="" S INAME="[BAD DATA]" 112 I TNAME="" S TNAME="[BAD DATA]" 113 I PNAME="" S PNAME="[BAD DATA]" 114 I '$D(@STORE@("I",INAME,IIEN)) S @STORE@("I",INAME,IIEN)="" 115 I '$D(@STORE@("T",IIEN,TNAME,TIEN)) S @STORE@("T",IIEN,TNAME,TIEN)="" 116 I '$D(@STORE@("P",IIEN,TIEN,PNAME,PIEN,TPIEN)) S @STORE@("P",IIEN,TIEN,PNAME,PIEN,TPIEN)="" 117 S @STORE@(IIEN)="Division: "_INAME 118 S @STORE@(IIEN,TIEN)="Team: "_TNAME 119 S $E(@STORE@(IIEN,TIEN),40)="Primary Care Team: "_$S(PC=1:"YES",1:"NO") 120 ; 121 S @STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN)=$E(PTNAME,1,17) 122 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),19)=PID 123 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),31)=ADATE 124 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),43)=PCAP 125 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),49)=$E(PNAME,1,21) 126 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),70)=$E(POS,1,20) 127 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),92)=$E(ROLN,1,20) 128 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),113)=$E(PRCN,1,20) 129 Q 130 ; 131 NOTA(PTIEN,PIEN) ; 132 ;PTIEN - patient team assignment (#404.42) 133 ;PIEN - patient ien 134 N IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POSIEN,POS,TPIEN 135 N ROLN,PCAP,PRCN,ADATE 136 S POS="[Not Assigned]",POSIEN=0 137 S PNAME="[Not Assigned]",PNIEN=0 138 S (ROLN,PCAP,PRCN,ADATE)="" 139 ; 140 S PTNAME=$E($P($G(^DPT(PIEN,0)),"^"),1,20) ;patient name 141 S PID=$P($G(^DPT(PIEN,.36)),"^",3),PID=$TR(PID,"-","") 142 ;S PID=$E(PID,6,10) ;9 digit ssn patch 526 143 ; 144 S TIEN=+$P($G(^SCPT(404.42,PTIEN,0)),"^",3) ;team ien 145 S TMN=$G(^SCTM(404.51,TIEN,0)) 146 Q:TMN="" 147 S TNAME=$P(TMN,"^") ;team name 148 S PC=$P(TMN,"^",5) ;primary care team 1/0 149 S IIEN=+$P(TMN,"^",7) ;institution ien 150 S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution name 151 ; 152 D FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POS,POSIEN,ADATE,PIEN,ROLN,PCAP,PRCN) 153 Q 1 SCRPTA2 ;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 ; 6 CHK(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 39 PRACI(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 ; 58 FOUND2(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 ; 92 FORMAT(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 ; 130 NOTA(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 TracChangeset
for help on using the changeset viewer.
