Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SCAPMCU2

SCAPMCU2.m

Go to the documentation of this file. 
  1. SCAPMCU2 ;ALB/REW - TEAM API UTILITIES ;6/29/99  19:40  ; Compiled May 29, 2007 15:16:13
  1.  ;;5.3;Scheduling;**41,177,205,458,1015**;AUG 13, 1993;Build 21
  1.  ;;1.0
  1. DTAFTER(FILE,IEN,STATUS,DATE) ;return next date after given one
  1.  N SCX
  1.  S SCX=-1
  1.  G:('$G(FILE))!("^404.52^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDTAF
  1.  S ROOT="^SCTM("_FILE_",""AIDT"",IEN,STATUS)"
  1.  S EFFDT=-DATE
  1.  S SCX=$P($O(@ROOT@(EFFDT),-1),"-",2)
  1. QTDTAF Q SCX
  1.  ;
  1. DTBEFORE(FILE,IEN,STATUS,DATE) ;return next date before given one
  1.  N SCX
  1.  S SCX=-1
  1.  G:('$G(FILE))!("^404.52^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDTBF
  1.  S ROOT="^SCTM("_FILE_",""AIDT"",IEN,STATUS)"
  1.  S EFFDT=-DATE
  1.  S SCX=$P($O(@ROOT@(EFFDT)),"-",2)
  1. QTDTBF Q SCX
  1.  ;
  1. ACTHISTB(FILE,IEN) ;boolean active function
  1.  ;abbreviated form of call below - no error handling
  1.  N X,SCACTB
  1.  S X=+$$ACTHIST(.FILE,.IEN,"SCACTB")
  1.  Q $S(X=1:1,1:0)
  1.  ;
  1. ACTHIST(FILE,IEN,SCDATES,SCERR,SCLIST) ;is entry active for a time period?
  1.  ; Input Parameters:
  1.  ;    File = either 404.52 or 404.58 or 404.59
  1.  ;    IEN  = pointer to team(404.51) or team position(404.57)
  1.  ;    SCDATES = (SEE PRIOR DEFINITION)
  1.  ;    SCLIST  = Output array
  1.  ;  Returned:
  1.  ;  status (-1:error|0:inactive|1:active)^ien for file^actdt^inacdt
  1.  ;          which ien depends on status
  1.  ;
  1.  N OK,X,ROOT,SCBEGIN,SCEND,SCINCL,SCDATE,SCA,SCDTS,SCE
  1.  S OK=-1,X=""
  1.  G:('$G(FILE))!("^404.52^404.53^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTACTH
  1.  S ROOT="^SCTM("_FILE_",""AIDT"",IEN,SCSTAT"
  1.  D INIT^SCAPMCU1(.OK) ; set default dates,output & error array (if undefined)
  1.  IF 'OK S OK=-1 G QTACTH
  1.  S SCDATE=SCEND
  1.  S OK=0
  1.  ;if incl=0 ->a partial hit should be returned
  1. LOOP IF 'SCINCL D
  1.  .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)
  1.  ..IF 'X S SCDATE=SCA Q
  1.  ..IF +X=1 D
  1.  ...S OK=1
  1.  ...S SCDATE=SCA-.000001
  1.  ...Q:$D(@SCLIST@(FILE,"SCLST",IEN,SCA))
  1.  ...S SCN=$G(@SCLIST@(FILE,0),0)+1
  1.  ...S @SCLIST@(FILE,0)=SCN
  1.  ...S @SCLIST@(FILE,SCN)=IEN_U_$$EXT(FILE,IEN)_U_SCA_U_$P(X,U,3)
  1.  ...S @SCLIST@(FILE,"SCLST",IEN,SCA,SCN)=""
  1.  ..ELSE  D
  1.  ...S OK=-1
  1.  ...S SCPARM("EFFECTIVE DATE")=$G(SCDATE,"Undefined")
  1.  ...D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
  1.  ELSE  D
  1.  .S X=$$DATES^SCAPMCU1(.FILE,.IEN,.SCDATE)
  1.  .IF X&($P(X,U,2)'>SCBEGIN) D
  1.  ..S OK=1
  1.  ..Q:$D(@SCLIST@(FILE,"SCLST",IEN,$P(X,U,2)))
  1.  ..S SCN=$G(@SCLIST@(FILE,0),0)+1
  1.  ..S @SCLIST@(FILE,0)=SCN
  1.  ..S @SCLIST@(FILE,SCN)=IEN_U_$$EXT(FILE,IEN)_U_$P(X,U,2)_U_$P(X,U,3)
  1.  ..S @SCLIST@(FILE,"SCLST",IEN,$P(X,U,2),SCN)=""
  1. QTACTH Q OK_U_$P(X,U,4)_U_$P(X,U,2)_U_$P(X,U,3)
  1.  ;
  1. EXT(FILE,IEN) ;return external value of team or team position file
  1.  N SCEXT
  1.  S SCEXT=-1
  1.  IF FILE=404.58 D
  1.  .S SCEXT=$P($G(^SCTM(404.51,+$G(IEN),0)),U,1)
  1.  .S:'$L(SCEXT) SCEXT=-1
  1.  IF "^404.52^404.53^404.59^"[(U_FILE_U) D
  1.  .S SCEXT=$P($G(^SCTM(404.57,+$G(IEN),0)),U,1)
  1.  .S:'$L(SCEXT) SCEXT=-1
  1. QTEXT Q SCEXT
  1.  ;
  1. GETPC(DFN,DATE,PCROLE,ASSTYPE) ;return pc position & team for a date
  1.  ; DFN - pointer to patient file
  1.  ; DATE - date of interest (Default=DT)
  1.  ; PCROLE - Default=1 (PC Practitioner Position) note 2= pc attending
  1.  ; ASSTYPE - Default=1 (PC Team)
  1.  ; returns sctp^sctm^assigned to pc?
  1.  ;
  1.  N ACTDT,SCTP,SCTM,SCPTA,INACTDT
  1.  Q $$GETPCTP(.DFN,.DATE,.PCROLE)_U_$$GETPCTM(.DFN,.DATE,.ASSTYPE)_U_($D(^SCPT(404.41,"APC",+DFN))>0)
  1.  ;
  1. HISTPTTP(DFN,SCTP,DATE) ;404.43 entry for pt,position - if active on date
  1.  ;return -1 if error, 0 if no active entry or 404.43 ien if one
  1.  Q:'$G(DFN)!('$G(SCTP))!('$G(DATE)) -1
  1.  N SCACT,HISTIEN,SCINACT,SCDT
  1.  S SCDT=DATE+.00000001
  1.  S SCACT=+$O(^SCPT(404.43,"ADFN",DFN,SCTP,SCDT),-1)
  1.  S HISTIEN=+$O(^SCPT(404.43,"ADFN",DFN,SCTP,SCACT,0))
  1.  S SCINACT=$P($G(^SCPT(404.43,HISTIEN,0)),U,4)
  1.  Q $S('SCACT:0,('HISTIEN):0,('SCINACT):HISTIEN,(DATE>SCINACT):0,1:HISTIEN)
  1.  ;
  1. HISTPTTM(DFN,SCTM,DATE) ;404.42 entry for tm,position - if active on date
  1.  ; return -1 if error, 0 if no active entry or 404.42 entyr if one
  1.  Q:'$G(DFN)!('$G(SCTM))!('$G(DATE)) -1
  1.  N SCACT,HISTIEN,SCINACT,SCDT
  1.  S SCDT=DATE+.00000001
  1.  S SCACT=-$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCDT))
  1.  S HISTIEN=+$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCACT,0))
  1.  S SCINACT=$P($G(^SCPT(404.42,HISTIEN,0)),U,9)
  1.  Q $S('SCACT:0,('HISTIEN):0,('SCINACT):HISTIEN,(DATE>SCINACT):0,1:HISTIEN)
  1.  ;
  1. GETPCTM(DFN,DATE,ASSTYPE) ;return pc team for a date
  1.  ; DFN - pointer to patient file
  1.  ; DATE - date of interest
  1.  ; ASSTYPE - Default=1 (PC Team)
  1.  ; returns sctm
  1.  ;
  1.  N ACTDT,SCTP,SCPTTMA,SCINDT,SCTM,SCGOOD
  1.  S ASSTYPE=$G(ASSTYPE,1)
  1.  S DATE=$G(DATE,DT)
  1.  ; returns pointer to 404.51, if exists, 0 if not
  1.  S ACTDT=+$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,(DATE+.000001)),-1)
  1.  I 'ACTDT Q 0
  1.  S SCTM=0,SCGOOD=0
  1.  F  S SCTM=$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,+ACTDT,SCTM)) Q:SCTM=""  D  Q:SCGOOD 
  1.  .S SCPTTMA=$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,+ACTDT,+SCTM,""),-1)
  1.  .S SCINDT=$P($G(^SCPT(404.42,+SCPTTMA,0)),U,9)
  1.  .I SCINDT="" S SCGOOD=1 Q 
  1.  Q $S('SCINDT:+SCTM,(SCINDT'<DATE):+SCTM,1:0)
  1.  ;
  1. GETPCTP(DFN,DATE,PCROLE) ;return pc position for a date
  1.  ; DFN - pointer to patient file
  1.  ; DATE - date of interest
  1.  ; PCROLE - Default=1 (PC Practitioner Position) note 2= pc attending
  1.  ; returns sctp,or 0 if none or -1 if error
  1.  ;
  1.  N ACTDT,SCTP,SCTM,SCPTA,INACTDT,SCPTTPA,SCOK,TPLP,TPDALP
  1.  S SCOK=1,SCTP=0
  1.  S DATE=$G(DATE,DT)
  1.  S PCROLE=$G(PCROLE,1)
  1.  ; returns pointer to 404.57, if exists, 0 if not
  1.  S ACTDT=+$O(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,(DATE+.000001)),-1)
  1.  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
  1.  .S INACTDT=$P($G(^SCPT(404.43,+TPDALP,0)),U,4)
  1.  .;if already an active date then an error
  1.  .I 'INACTDT S SCTP=$S(SCTP>0:-1,1:TPLP) Q
  1.  .I INACTDT'<DATE S SCTP=$S(SCTP>0:-1,1:TPLP)
  1.  .Q
  1.  Q +SCTP
  1.  ;
  1. GETPRTP(SCTP,DATE) ;returns ien & name of practitioner filling position
  1.  ;   Returned [Error:-1,Else: sc200^practname]
  1.  N X,SCPRDTS,SCPR
  1.  S DATE=$G(DATE,DT)
  1.  S SCPRDTS("BEGIN")=DATE
  1.  S SCPRDTS("END")=DATE
  1.  S X=$$PRTP^SCAPMC(SCTP,"SCPRDTS","SCPR")
  1.  Q $S(X<1:-1,1:$P($G(SCPR(1)),U,1)_U_$P($G(SCPR(1)),U,2))
  1.  ;
  1. EXTMPRTP(SCTP,DATE) ;returns external of team and practitioner for position
  1.  ;
  1.  N SCX
  1.  S SCX=$$GETPRTP(.SCTP,.DATE)
  1.  Q $P($G(^SCTM(404.51,+$P($G(^SCTM(404.57,+SCTP,0)),U,2),0)),U,1)_"   "_$P(SCX,U,2)
  1.  ;
  1. NMPCTP(DFN,DATE,PCROLE) ;returns ien & name of pc position
  1.  ; (See GETPCTP for variables)
  1.  N X
  1.  S X=$$GETPCTP(DFN,.DATE,.PCROLE)
  1.  Q $S('$G(X):"",X=-1:"",1:X_U_$P($G(^SCTM(404.57,+X,0)),U,1))
  1.  ;
  1. NMPCPR(DFN,DATE,PCROLE) ;returns ien & name of pract filling pc position
  1.  ; DFN - pointer to patient file 
  1.  ; DATE - date of interest 
  1.  ; PCROLE - Practitioner Position where '1' = PC provider
  1.  ;                                      '2' = PC attending 
  1.  ;                                      '3' = PC associate provider
  1.  ;
  1.  ; returns sctp (ien^name), or "" if none or -1 if error 
  1.  ; 
  1.  N SCTP,PCAP
  1.  ;bp/cmf 205 original code next line
  1.  ;S PCAP=PCROLE S:PCROLE=3 PCROLE=1
  1.  ;bp/cmf 205 change code begin
  1.  ;;S PCROLE=+$G(PCROLE,1),(PCAP,PCROLE)=$S(PCROLE=0:1,PCROLE>2:1,1:PCROLE)
  1.  S (PCROLE,PCAP)=+$G(PCROLE,1)
  1.  S PCAP=$S(PCAP=0:1,PCAP>3:1,1:PCAP)
  1.  S PCROLE=$S(PCROLE=0:1,PCROLE>2:1,1:PCROLE)
  1.  ;bp/cmf 205 change code end
  1.  S SCTP=+$$NMPCTP(.DFN,.DATE,.PCROLE)
  1.  Q $S('SCTP:"",1:$$PCPROV^SCAPMCU3(SCTP,.DATE,PCAP))
  1.  ;
  1. NMPCTM(DFN,DATE,PCROLE) ;returns ien & name of pc team
  1.  ; (See GETPCTM for variables)
  1.  N X
  1.  S X=$$GETPCTM(DFN,.DATE,.PCROLE)
  1.  Q $S('$G(X):"",1:X_U_$P($G(^SCTM(404.51,+X,0)),U,1))
  1.  ;
  1. ALPHA(INARRAY,OUTARRAY) ;not supported - for PCMM only
  1.  ; returns array sorted by 2nd piece's value
  1.  ; it keeps the 0 node -it does not return any x-ref values
  1.  ; it only converts arrays of type 1-n to another 1-n array
  1.  N SCNDX,SCX,SCNODE,SCY
  1.  S (SCX,SCY)=0
  1.  S:$D(@INARRAY@(0)) @OUTARRAY@(0)=@INARRAY@(0)
  1.  F  S SCX=$O(@INARRAY@(SCX)) Q:'SCX  S SCNODE=@INARRAY@(SCX) Q:'$L(SCNODE)  D
  1.  .S ^TMP($J,"SCTMPSORT","B",$P(SCNODE,U,2),SCX)=""
  1.  S SCNDX=""
  1.  F  S SCNDX=$O(^TMP($J,"SCTMPSORT","B",SCNDX)) Q:SCNDX=""  D
  1.  .S SCX=0
  1.  .F  S SCX=$O(^TMP($J,"SCTMPSORT","B",SCNDX,SCX)) Q:'SCX  D
  1.  ..S SCY=SCY+1
  1.  ..S @OUTARRAY@(SCY)=$G(@INARRAY@(SCX))
  1.  K ^TMP($J,"SCTMPSORT","B")
  1.  Q