| 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
|
|---|
