Changeset 623 for WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMCU2.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMCU2.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMCU2.m
r613 r623 1 SCAPMCU2 ;ALB/REW - TEAM API UTILITIES ;6/29/99 19:40 ; Compiled May 29, 2007 15:16:13 2 ;;5.3;Scheduling;**41,177,205,458**;AUG 13, 1993;Build 14 3 ;;1.0 4 DTAFTER(FILE,IEN,STATUS,DATE) ;return next date after given one 5 N SCX 6 S SCX=-1 7 G:('$G(FILE))!("^404.52^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDTAF 8 S ROOT="^SCTM("_FILE_",""AIDT"",IEN,STATUS)" 9 S EFFDT=-DATE 10 S SCX=$P($O(@ROOT@(EFFDT),-1),"-",2) 11 QTDTAF Q SCX 12 ; 13 DTBEFORE(FILE,IEN,STATUS,DATE) ;return next date before given one 14 N SCX 15 S SCX=-1 16 G:('$G(FILE))!("^404.52^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDTBF 17 S ROOT="^SCTM("_FILE_",""AIDT"",IEN,STATUS)" 18 S EFFDT=-DATE 19 S SCX=$P($O(@ROOT@(EFFDT)),"-",2) 20 QTDTBF Q SCX 21 ; 22 ACTHISTB(FILE,IEN) ;boolean active function 23 ;abbreviated form of call below - no error handling 24 N X,SCACTB 25 S X=+$$ACTHIST(.FILE,.IEN,"SCACTB") 26 Q $S(X=1:1,1:0) 27 ; 28 ACTHIST(FILE,IEN,SCDATES,SCERR,SCLIST) ;is entry active for a time period? 29 ; Input Parameters: 30 ; File = either 404.52 or 404.58 or 404.59 31 ; IEN = pointer to team(404.51) or team position(404.57) 32 ; SCDATES = (SEE PRIOR DEFINITION) 33 ; SCLIST = Output array 34 ; Returned: 35 ; status (-1:error|0:inactive|1:active)^ien for file^actdt^inacdt 36 ; which ien depends on status 37 ; 38 N OK,X,ROOT,SCBEGIN,SCEND,SCINCL,SCDATE,SCA,SCDTS,SCE 39 S OK=-1,X="" 40 G:('$G(FILE))!("^404.52^404.53^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTACTH 41 S ROOT="^SCTM("_FILE_",""AIDT"",IEN,SCSTAT" 42 D INIT^SCAPMCU1(.OK) ; set default dates,output & error array (if undefined) 43 IF 'OK S OK=-1 G QTACTH 44 S SCDATE=SCEND 45 S OK=0 46 ;if incl=0 ->a partial hit should be returned 47 LOOP IF 'SCINCL D 48 .F S X=$$DATES^SCAPMCU1(.FILE,.IEN,.SCDATE) S SCA=$P(X,U,2),SCE=$P(X,U,3) D Q:$P(X,U,5)!(SCE<SCBEGIN)!(OK=-1) 49 ..IF 'X S SCDATE=SCA Q 50 ..IF +X=1 D 51 ...S OK=1 52 ...S SCDATE=SCA-.000001 53 ...Q:$D(@SCLIST@(FILE,"SCLST",IEN,SCA)) 54 ...S SCN=$G(@SCLIST@(FILE,0),0)+1 55 ...S @SCLIST@(FILE,0)=SCN 56 ...S @SCLIST@(FILE,SCN)=IEN_U_$$EXT(FILE,IEN)_U_SCA_U_$P(X,U,3) 57 ...S @SCLIST@(FILE,"SCLST",IEN,SCA,SCN)="" 58 ..ELSE D 59 ...S OK=-1 60 ...S SCPARM("EFFECTIVE DATE")=$G(SCDATE,"Undefined") 61 ...D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR) 62 ELSE D 63 .S X=$$DATES^SCAPMCU1(.FILE,.IEN,.SCDATE) 64 .IF X&($P(X,U,2)'>SCBEGIN) D 65 ..S OK=1 66 ..Q:$D(@SCLIST@(FILE,"SCLST",IEN,$P(X,U,2))) 67 ..S SCN=$G(@SCLIST@(FILE,0),0)+1 68 ..S @SCLIST@(FILE,0)=SCN 69 ..S @SCLIST@(FILE,SCN)=IEN_U_$$EXT(FILE,IEN)_U_$P(X,U,2)_U_$P(X,U,3) 70 ..S @SCLIST@(FILE,"SCLST",IEN,$P(X,U,2),SCN)="" 71 QTACTH Q OK_U_$P(X,U,4)_U_$P(X,U,2)_U_$P(X,U,3) 72 ; 73 EXT(FILE,IEN) ;return external value of team or team position file 74 N SCEXT 75 S SCEXT=-1 76 IF FILE=404.58 D 77 .S SCEXT=$P($G(^SCTM(404.51,+$G(IEN),0)),U,1) 78 .S:'$L(SCEXT) SCEXT=-1 79 IF "^404.52^404.53^404.59^"[(U_FILE_U) D 80 .S SCEXT=$P($G(^SCTM(404.57,+$G(IEN),0)),U,1) 81 .S:'$L(SCEXT) SCEXT=-1 82 QTEXT Q SCEXT 83 ; 84 GETPC(DFN,DATE,PCROLE,ASSTYPE) ;return pc position & team for a date 85 ; DFN - pointer to patient file 86 ; DATE - date of interest (Default=DT) 87 ; PCROLE - Default=1 (PC Practitioner Position) note 2= pc attending 88 ; ASSTYPE - Default=1 (PC Team) 89 ; returns sctp^sctm^assigned to pc? 90 ; 91 N ACTDT,SCTP,SCTM,SCPTA,INACTDT 92 Q $$GETPCTP(.DFN,.DATE,.PCROLE)_U_$$GETPCTM(.DFN,.DATE,.ASSTYPE)_U_($D(^SCPT(404.41,"APC",+DFN))>0) 93 ; 94 HISTPTTP(DFN,SCTP,DATE) ;404.43 entry for pt,position - if active on date 95 ;return -1 if error, 0 if no active entry or 404.43 ien if one 96 Q:'$G(DFN)!('$G(SCTP))!('$G(DATE)) -1 97 N SCACT,HISTIEN,SCINACT,SCDT 98 S SCDT=DATE+.00000001 99 S SCACT=+$O(^SCPT(404.43,"ADFN",DFN,SCTP,SCDT),-1) 100 S HISTIEN=+$O(^SCPT(404.43,"ADFN",DFN,SCTP,SCACT,0)) 101 S SCINACT=$P($G(^SCPT(404.43,HISTIEN,0)),U,4) 102 Q $S('SCACT:0,('HISTIEN):0,('SCINACT):HISTIEN,(DATE>SCINACT):0,1:HISTIEN) 103 ; 104 HISTPTTM(DFN,SCTM,DATE) ;404.42 entry for tm,position - if active on date 105 ; return -1 if error, 0 if no active entry or 404.42 entyr if one 106 Q:'$G(DFN)!('$G(SCTM))!('$G(DATE)) -1 107 N SCACT,HISTIEN,SCINACT,SCDT 108 S SCDT=DATE+.00000001 109 S SCACT=-$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCDT)) 110 S HISTIEN=+$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCACT,0)) 111 S SCINACT=$P($G(^SCPT(404.42,HISTIEN,0)),U,9) 112 Q $S('SCACT:0,('HISTIEN):0,('SCINACT):HISTIEN,(DATE>SCINACT):0,1:HISTIEN) 113 ; 114 GETPCTM(DFN,DATE,ASSTYPE) ;return pc team for a date 115 ; DFN - pointer to patient file 116 ; DATE - date of interest 117 ; ASSTYPE - Default=1 (PC Team) 118 ; returns sctm 119 ; 120 N ACTDT,SCTP,SCPTTMA,SCINDT,SCTM,SCGOOD 121 S ASSTYPE=$G(ASSTYPE,1) 122 S DATE=$G(DATE,DT) 123 ; returns pointer to 404.51, if exists, 0 if not 124 S ACTDT=+$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,(DATE+.000001)),-1) 125 I 'ACTDT Q 0 126 S SCTM=0,SCGOOD=0 127 F S SCTM=$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,+ACTDT,SCTM)) Q:SCTM="" D Q:SCGOOD 128 .S SCPTTMA=$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,+ACTDT,+SCTM,""),-1) 129 .S SCINDT=$P($G(^SCPT(404.42,+SCPTTMA,0)),U,9) 130 .I SCINDT="" S SCGOOD=1 Q 131 Q $S('SCINDT:+SCTM,(SCINDT'<DATE):+SCTM,1:0) 132 ; 133 GETPCTP(DFN,DATE,PCROLE) ;return pc position for a date 134 ; DFN - pointer to patient file 135 ; DATE - date of interest 136 ; PCROLE - Default=1 (PC Practitioner Position) note 2= pc attending 137 ; returns sctp,or 0 if none or -1 if error 138 ; 139 N ACTDT,SCTP,SCTM,SCPTA,INACTDT,SCPTTPA,SCOK,TPLP,TPDALP 140 S SCOK=1,SCTP=0 141 S DATE=$G(DATE,DT) 142 S PCROLE=$G(PCROLE,1) 143 ; returns pointer to 404.57, if exists, 0 if not 144 S ACTDT=+$O(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,(DATE+.000001)),-1) 145 F TPLP=0:0 S TPLP=$O(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,+ACTDT,TPLP)) Q:TPLP=""!(SCTP=-1) F TPDALP=0:0 S TPDALP=$O(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,+ACTDT,TPLP,TPDALP)) Q:TPDALP="" DO Q:SCTP=-1 146 .S INACTDT=$P($G(^SCPT(404.43,+TPDALP,0)),U,4) 147 .;if already an active date then an error 148 .I 'INACTDT S SCTP=$S(SCTP>0:-1,1:TPLP) Q 149 .I INACTDT'<DATE S SCTP=$S(SCTP>0:-1,1:TPLP) 150 .Q 151 Q +SCTP 152 ; 153 GETPRTP(SCTP,DATE) ;returns ien & name of practitioner filling position 154 ; Returned [Error:-1,Else: sc200^practname] 155 N X,SCPRDTS,SCPR 156 S DATE=$G(DATE,DT) 157 S SCPRDTS("BEGIN")=DATE 158 S SCPRDTS("END")=DATE 159 S X=$$PRTP^SCAPMC(SCTP,"SCPRDTS","SCPR") 160 Q $S(X<1:-1,1:$P($G(SCPR(1)),U,1)_U_$P($G(SCPR(1)),U,2)) 161 ; 162 EXTMPRTP(SCTP,DATE) ;returns external of team and practitioner for position 163 ; 164 N SCX 165 S SCX=$$GETPRTP(.SCTP,.DATE) 166 Q $P($G(^SCTM(404.51,+$P($G(^SCTM(404.57,+SCTP,0)),U,2),0)),U,1)_" "_$P(SCX,U,2) 167 ; 168 NMPCTP(DFN,DATE,PCROLE) ;returns ien & name of pc position 169 ; (See GETPCTP for variables) 170 N X 171 S X=$$GETPCTP(DFN,.DATE,.PCROLE) 172 Q $S('$G(X):"",X=-1:"",1:X_U_$P($G(^SCTM(404.57,+X,0)),U,1)) 173 ; 174 NMPCPR(DFN,DATE,PCROLE) ;returns ien & name of pract filling pc position 175 ; DFN - pointer to patient file 176 ; DATE - date of interest 177 ; PCROLE - Practitioner Position where '1' = PC provider 178 ; '2' = PC attending 179 ; '3' = PC associate provider 180 ; 181 ; returns sctp (ien^name), or "" if none or -1 if error 182 ; 183 N SCTP,PCAP 184 ;bp/cmf 205 original code next line 185 ;S PCAP=PCROLE S:PCROLE=3 PCROLE=1 186 ;bp/cmf 205 change code begin 187 ;;S PCROLE=+$G(PCROLE,1),(PCAP,PCROLE)=$S(PCROLE=0:1,PCROLE>2:1,1:PCROLE) 188 S (PCROLE,PCAP)=+$G(PCROLE,1) 189 S PCAP=$S(PCAP=0:1,PCAP>3:1,1:PCAP) 190 S PCROLE=$S(PCROLE=0:1,PCROLE>2:1,1:PCROLE) 191 ;bp/cmf 205 change code end 192 S SCTP=+$$NMPCTP(.DFN,.DATE,.PCROLE) 193 Q $S('SCTP:"",1:$$PCPROV^SCAPMCU3(SCTP,.DATE,PCAP)) 194 ; 195 NMPCTM(DFN,DATE,PCROLE) ;returns ien & name of pc team 196 ; (See GETPCTM for variables) 197 N X 198 S X=$$GETPCTM(DFN,.DATE,.PCROLE) 199 Q $S('$G(X):"",1:X_U_$P($G(^SCTM(404.51,+X,0)),U,1)) 200 ; 201 ALPHA(INARRAY,OUTARRAY) ;not supported - for PCMM only 202 ; returns array sorted by 2nd piece's value 203 ; it keeps the 0 node -it does not return any x-ref values 204 ; it only converts arrays of type 1-n to another 1-n array 205 N SCNDX,SCX,SCNODE,SCY 206 S (SCX,SCY)=0 207 S:$D(@INARRAY@(0)) @OUTARRAY@(0)=@INARRAY@(0) 208 F S SCX=$O(@INARRAY@(SCX)) Q:'SCX S SCNODE=@INARRAY@(SCX) Q:'$L(SCNODE) D 209 .S ^TMP($J,"SCTMPSORT","B",$P(SCNODE,U,2),SCX)="" 210 S SCNDX="" 211 F S SCNDX=$O(^TMP($J,"SCTMPSORT","B",SCNDX)) Q:SCNDX="" D 212 .S SCX=0 213 .F S SCX=$O(^TMP($J,"SCTMPSORT","B",SCNDX,SCX)) Q:'SCX D 214 ..S SCY=SCY+1 215 ..S @OUTARRAY@(SCY)=$G(@INARRAY@(SCX)) 216 K ^TMP($J,"SCTMPSORT","B") 217 Q 1 SCAPMCU2 ;ALB/REW - TEAM API UTILITIES ;6/29/99 19:40 2 ;;5.3;Scheduling;**41,177,205**;AUG 13, 1993 3 ;;1.0 4 DTAFTER(FILE,IEN,STATUS,DATE) ;return next date after given one 5 N SCX 6 S SCX=-1 7 G:('$G(FILE))!("^404.52^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDTAF 8 S ROOT="^SCTM("_FILE_",""AIDT"",IEN,STATUS)" 9 S EFFDT=-DATE 10 S SCX=$P($O(@ROOT@(EFFDT),-1),"-",2) 11 QTDTAF Q SCX 12 ; 13 DTBEFORE(FILE,IEN,STATUS,DATE) ;return next date before given one 14 N SCX 15 S SCX=-1 16 G:('$G(FILE))!("^404.52^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDTBF 17 S ROOT="^SCTM("_FILE_",""AIDT"",IEN,STATUS)" 18 S EFFDT=-DATE 19 S SCX=$P($O(@ROOT@(EFFDT)),"-",2) 20 QTDTBF Q SCX 21 ; 22 ACTHISTB(FILE,IEN) ;boolean active function 23 ;abbreviated form of call below - no error handling 24 N X,SCACTB 25 S X=+$$ACTHIST(.FILE,.IEN,"SCACTB") 26 Q $S(X=1:1,1:0) 27 ; 28 ACTHIST(FILE,IEN,SCDATES,SCERR,SCLIST) ;is entry active for a time period? 29 ; Input Parameters: 30 ; File = either 404.52 or 404.58 or 404.59 31 ; IEN = pointer to team(404.51) or team position(404.57) 32 ; SCDATES = (SEE PRIOR DEFINITION) 33 ; SCLIST = Output array 34 ; Returned: 35 ; status (-1:error|0:inactive|1:active)^ien for file^actdt^inacdt 36 ; which ien depends on status 37 ; 38 N OK,X,ROOT,SCBEGIN,SCEND,SCINCL,SCDATE,SCA,SCDTS,SCE 39 S OK=-1,X="" 40 G:('$G(FILE))!("^404.52^404.53^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTACTH 41 S ROOT="^SCTM("_FILE_",""AIDT"",IEN,SCSTAT" 42 D INIT^SCAPMCU1(.OK) ; set default dates,output & error array (if undefined) 43 IF 'OK S OK=-1 G QTACTH 44 S SCDATE=SCEND 45 S OK=0 46 ;if incl=0 ->a partial hit should be returned 47 LOOP IF 'SCINCL D 48 .F S X=$$DATES^SCAPMCU1(.FILE,.IEN,.SCDATE) S SCA=$P(X,U,2),SCE=$P(X,U,3) D Q:$P(X,U,5)!(SCE<SCBEGIN)!(OK=-1) 49 ..IF 'X S SCDATE=SCA Q 50 ..IF +X=1 D 51 ...S OK=1 52 ...S SCDATE=SCA-.000001 53 ...Q:$D(@SCLIST@(FILE,"SCLST",IEN,SCA)) 54 ...S SCN=$G(@SCLIST@(FILE,0),0)+1 55 ...S @SCLIST@(FILE,0)=SCN 56 ...S @SCLIST@(FILE,SCN)=IEN_U_$$EXT(FILE,IEN)_U_SCA_U_$P(X,U,3) 57 ...S @SCLIST@(FILE,"SCLST",IEN,SCA,SCN)="" 58 ..ELSE D 59 ...S OK=-1 60 ...S SCPARM("EFFECTIVE DATE")=$G(SCDATE,"Undefined") 61 ...D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR) 62 ELSE D 63 .S X=$$DATES^SCAPMCU1(.FILE,.IEN,.SCDATE) 64 .IF X&($P(X,U,2)'>SCBEGIN) D 65 ..S OK=1 66 ..Q:$D(@SCLIST@(FILE,"SCLST",IEN,$P(X,U,2))) 67 ..S SCN=$G(@SCLIST@(FILE,0),0)+1 68 ..S @SCLIST@(FILE,0)=SCN 69 ..S @SCLIST@(FILE,SCN)=IEN_U_$$EXT(FILE,IEN)_U_$P(X,U,2)_U_$P(X,U,3) 70 ..S @SCLIST@(FILE,"SCLST",IEN,$P(X,U,2),SCN)="" 71 QTACTH Q OK_U_$P(X,U,4)_U_$P(X,U,2)_U_$P(X,U,3) 72 ; 73 EXT(FILE,IEN) ;return external value of team or team position file 74 N SCEXT 75 S SCEXT=-1 76 IF FILE=404.58 D 77 .S SCEXT=$P($G(^SCTM(404.51,+$G(IEN),0)),U,1) 78 .S:'$L(SCEXT) SCEXT=-1 79 IF "^404.52^404.53^404.59^"[(U_FILE_U) D 80 .S SCEXT=$P($G(^SCTM(404.57,+$G(IEN),0)),U,1) 81 .S:'$L(SCEXT) SCEXT=-1 82 QTEXT Q SCEXT 83 ; 84 GETPC(DFN,DATE,PCROLE,ASSTYPE) ;return pc position & team for a date 85 ; DFN - pointer to patient file 86 ; DATE - date of interest (Default=DT) 87 ; PCROLE - Default=1 (PC Practitioner Position) note 2= pc attending 88 ; ASSTYPE - Default=1 (PC Team) 89 ; returns sctp^sctm^assigned to pc? 90 ; 91 N ACTDT,SCTP,SCTM,SCPTA,INACTDT 92 Q $$GETPCTP(.DFN,.DATE,.PCROLE)_U_$$GETPCTM(.DFN,.DATE,.ASSTYPE)_U_($D(^SCPT(404.41,"APC",+DFN))>0) 93 ; 94 HISTPTTP(DFN,SCTP,DATE) ;404.43 entry for pt,position - if active on date 95 ;return -1 if error, 0 if no active entry or 404.43 ien if one 96 Q:'$G(DFN)!('$G(SCTP))!('$G(DATE)) -1 97 N SCACT,HISTIEN,SCINACT,SCDT 98 S SCDT=DATE+.00000001 99 S SCACT=+$O(^SCPT(404.43,"ADFN",DFN,SCTP,SCDT),-1) 100 S HISTIEN=+$O(^SCPT(404.43,"ADFN",DFN,SCTP,SCACT,0)) 101 S SCINACT=$P($G(^SCPT(404.43,HISTIEN,0)),U,4) 102 Q $S('SCACT:0,('HISTIEN):0,('SCINACT):HISTIEN,(DATE>SCINACT):0,1:HISTIEN) 103 ; 104 HISTPTTM(DFN,SCTM,DATE) ;404.42 entry for tm,position - if active on date 105 ; return -1 if error, 0 if no active entry or 404.42 entyr if one 106 Q:'$G(DFN)!('$G(SCTM))!('$G(DATE)) -1 107 N SCACT,HISTIEN,SCINACT,SCDT 108 S SCDT=DATE+.00000001 109 S SCACT=-$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCDT)) 110 S HISTIEN=+$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCACT,0)) 111 S SCINACT=$P($G(^SCPT(404.42,HISTIEN,0)),U,9) 112 Q $S('SCACT:0,('HISTIEN):0,('SCINACT):HISTIEN,(DATE>SCINACT):0,1:HISTIEN) 113 ; 114 GETPCTM(DFN,DATE,ASSTYPE) ;return pc team for a date 115 ; DFN - pointer to patient file 116 ; DATE - date of interest 117 ; ASSTYPE - Default=1 (PC Team) 118 ; returns sctm 119 ; 120 N ACTDT,SCTP,SCPTTMA,INACTDT,SCTM 121 S ASSTYPE=$G(ASSTYPE,1) 122 S DATE=$G(DATE,DT) 123 ; returns pointer to 404.51, if exists, 0 if not 124 S ACTDT=+$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,(DATE+.000001)),-1) 125 S SCTM=$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,+ACTDT,0)) 126 S SCPTTMA=$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,+ACTDT,+SCTM,0)) 127 S INACTDT=$P($G(^SCPT(404.42,+SCPTTMA,0)),U,9) 128 Q $S('INACTDT:+SCTM,(INACTDT'<DATE):+SCTM,1:0) 129 ; 130 GETPCTP(DFN,DATE,PCROLE) ;return pc position for a date 131 ; DFN - pointer to patient file 132 ; DATE - date of interest 133 ; PCROLE - Default=1 (PC Practitioner Position) note 2= pc attending 134 ; returns sctp,or 0 if none or -1 if error 135 ; 136 N ACTDT,SCTP,SCTM,SCPTA,INACTDT,SCPTTPA,SCOK,TPLP,TPDALP 137 S SCOK=1,SCTP=0 138 S DATE=$G(DATE,DT) 139 S PCROLE=$G(PCROLE,1) 140 ; returns pointer to 404.57, if exists, 0 if not 141 S ACTDT=+$O(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,(DATE+.000001)),-1) 142 F TPLP=0:0 S TPLP=$O(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,+ACTDT,TPLP)) Q:TPLP=""!(SCTP=-1) F TPDALP=0:0 S TPDALP=$O(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,+ACTDT,TPLP,TPDALP)) Q:TPDALP="" DO Q:SCTP=-1 143 .S INACTDT=$P($G(^SCPT(404.43,+TPDALP,0)),U,4) 144 .;if already an active date then an error 145 .I 'INACTDT S SCTP=$S(SCTP>0:-1,1:TPLP) Q 146 .I INACTDT'<DATE S SCTP=$S(SCTP>0:-1,1:TPLP) 147 .Q 148 Q +SCTP 149 ; 150 GETPRTP(SCTP,DATE) ;returns ien & name of practitioner filling position 151 ; Returned [Error:-1,Else: sc200^practname] 152 N X,SCPRDTS,SCPR 153 S DATE=$G(DATE,DT) 154 S SCPRDTS("BEGIN")=DATE 155 S SCPRDTS("END")=DATE 156 S X=$$PRTP^SCAPMC(SCTP,"SCPRDTS","SCPR") 157 Q $S(X<1:-1,1:$P($G(SCPR(1)),U,1)_U_$P($G(SCPR(1)),U,2)) 158 ; 159 EXTMPRTP(SCTP,DATE) ;returns external of team and practitioner for position 160 ; 161 N SCX 162 S SCX=$$GETPRTP(.SCTP,.DATE) 163 Q $P($G(^SCTM(404.51,+$P($G(^SCTM(404.57,+SCTP,0)),U,2),0)),U,1)_" "_$P(SCX,U,2) 164 ; 165 NMPCTP(DFN,DATE,PCROLE) ;returns ien & name of pc position 166 ; (See GETPCTP for variables) 167 N X 168 S X=$$GETPCTP(DFN,.DATE,.PCROLE) 169 Q $S('$G(X):"",X=-1:"",1:X_U_$P($G(^SCTM(404.57,+X,0)),U,1)) 170 ; 171 NMPCPR(DFN,DATE,PCROLE) ;returns ien & name of pract filling pc position 172 ; DFN - pointer to patient file 173 ; DATE - date of interest 174 ; PCROLE - Practitioner Position where '1' = PC provider 175 ; '2' = PC attending 176 ; '3' = PC associate provider 177 ; 178 ; returns sctp (ien^name), or "" if none or -1 if error 179 ; 180 N SCTP,PCAP 181 ;bp/cmf 205 original code next line 182 ;S PCAP=PCROLE S:PCROLE=3 PCROLE=1 183 ;bp/cmf 205 change code begin 184 ;;S PCROLE=+$G(PCROLE,1),(PCAP,PCROLE)=$S(PCROLE=0:1,PCROLE>2:1,1:PCROLE) 185 S (PCROLE,PCAP)=+$G(PCROLE,1) 186 S PCAP=$S(PCAP=0:1,PCAP>3:1,1:PCAP) 187 S PCROLE=$S(PCROLE=0:1,PCROLE>2:1,1:PCROLE) 188 ;bp/cmf 205 change code end 189 S SCTP=+$$NMPCTP(.DFN,.DATE,.PCROLE) 190 Q $S('SCTP:"",1:$$PCPROV^SCAPMCU3(SCTP,.DATE,PCAP)) 191 ; 192 NMPCTM(DFN,DATE,PCROLE) ;returns ien & name of pc team 193 ; (See GETPCTM for variables) 194 N X 195 S X=$$GETPCTM(DFN,.DATE,.PCROLE) 196 Q $S('$G(X):"",1:X_U_$P($G(^SCTM(404.51,+X,0)),U,1)) 197 ; 198 ALPHA(INARRAY,OUTARRAY) ;not supported - for PCMM only 199 ; returns array sorted by 2nd piece's value 200 ; it keeps the 0 node -it does not return any x-ref values 201 ; it only converts arrays of type 1-n to another 1-n array 202 N SCNDX,SCX,SCNODE,SCY 203 S (SCX,SCY)=0 204 S:$D(@INARRAY@(0)) @OUTARRAY@(0)=@INARRAY@(0) 205 F S SCX=$O(@INARRAY@(SCX)) Q:'SCX S SCNODE=@INARRAY@(SCX) Q:'$L(SCNODE) D 206 .S ^TMP($J,"SCTMPSORT","B",$P(SCNODE,U,2),SCX)="" 207 S SCNDX="" 208 F S SCNDX=$O(^TMP($J,"SCTMPSORT","B",SCNDX)) Q:SCNDX="" D 209 .S SCX=0 210 .F S SCX=$O(^TMP($J,"SCTMPSORT","B",SCNDX,SCX)) Q:'SCX D 211 ..S SCY=SCY+1 212 ..S @OUTARRAY@(SCY)=$G(@INARRAY@(SCX)) 213 K ^TMP($J,"SCTMPSORT","B") 214 Q
Note:
See TracChangeset
for help on using the changeset viewer.
