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

SCAPMCU3.m

Go to the documentation of this file. 
  1. SCAPMCU3 ;MJK/ALB - AUTOLINK API ; 8/10/99 4:09pm
  1.  ;;5.3;Scheduling;**41,45,177,204,1015**;AUG 13, 1993;Build 21
  1.  ;
  1. GETREC(SCDATA,SCTEAM) ; -- get team record with autolink data
  1.  ; input  :    SCTEAM := ien of team
  1.  ; output : SCDATA is the return array
  1.  ;          SCDATA(0) := 0th node of Team
  1.  ;             (1..n) := autolink name ^ autolink type ^ ien of entity
  1.  ;
  1.  N SC,X
  1.  ; -- get 0th node of team
  1.  S X=$$GETEAM(SCTEAM)
  1.  ; -- add to return array
  1.  D SET(X,0,.SCDATA)
  1.  ; -- find all autolinks for team
  1.  D SCAN(SCTEAM,.SC)
  1.  ; -- build autolink string and add to return array
  1.  D BUILD(.SC,.SCDATA)
  1.  Q
  1.  ;
  1. BUILD(SC,SCDATA) ; -- build string to send and add to return array
  1.  N SCLINK,SCINC,X,SCGLB,SCTYPE
  1.  S SCINC=1
  1.  S SCLINK=""
  1.  F  S SCLINK=$O(SC(SCLINK)) Q:SCLINK=""  D
  1.  . S X=SCLINK
  1.  . IF X["DIC(42," S SCGLB="^DIC(42)",SCTYPE="WARD"
  1.  . IF X["DIC(45.7," S SCGLB="^DIC(45.7)",SCTYPE="SPECIALTY"
  1.  . IF X["VA(200," S SCGLB="^VA(200)",SCTYPE="PRACTITIONER"
  1.  . IF X["DG(405.4," S SCGLB="^DG(405.4)",SCTYPE="ROOM"
  1.  . IF X["SC(" S SCGLB="^SC",SCTYPE="CLINIC"
  1.  . ; - add data to return array
  1.  . IF $D(@SCGLB@(+SCLINK,0)) D SET($P(^(0),U)_U_SCTYPE_U_+SCLINK,.SCINC,.SCDATA)
  1.  Q
  1.  ;
  1. SET(X,INC,SCDATA) ; -- set value in return array
  1.  S INC=$G(INC)+1,SCDATA(INC)=X
  1.  Q
  1.  ;
  1. SETREC(SCOK,SCTEAM,SC) ; -- add/edit autolink data to Team record
  1.  ; input  :    SCTEAM := ien of team
  1.  ; output : SC is the input array
  1.  ;           SC(1..n) := autolink name ^ autolink type ^ ien of entity
  1.  ;
  1.  N SCTYPE,SCROOT,SCGLB,SCLINK,SCLINKI,SCI,SCOLD,SCNEW
  1.  ; -- build array of current autolink assignments
  1.  D SCAN(SCTEAM,.SCOLD)
  1.  ;
  1.  ; -- compare current with input  and add autolinks if in
  1.  ;    input array but not in current array
  1.  S SCI=0 F  S SCI=$O(SC(SCI)) Q:'SCI  S SCX=SC(SCI) D
  1.  . S SCTYPE=$P(SCX,U,2)
  1.  . D ROOT(SCTYPE,.SCROOT,.SCGLB)
  1.  . S SCLINK=+$P(SCX,U,3)_";"_SCROOT
  1.  . S SCNEW(SCLINK)=""
  1.  . IF '$D(SCOLD(SCLINK)),SCGLB]"",$D(@SCGLB@(+SCLINK,0)) D ADD(SCTEAM,SCLINK)
  1.  ;
  1.  ; -- compare current with input and delete autolinks if not
  1.  ;    in input array but in current array
  1.  S SCLINK=""
  1.  F  S SCLINK=$O(SCOLD(SCLINK)) Q:'SCLINK  IF '$D(SCNEW(SCLINK)) D
  1.  . S SCLINKI=+SCOLD(SCLINK)
  1.  . IF SCLINKI D DELETE(SCLINKI)
  1.  S SCOK=1
  1.  Q
  1.  ;
  1. ADD(SCTEAM,SCLINK) ; -- add an autolink to a Team
  1.  N DIC,DD,DO,DLAYGO
  1.  S DIC="^SCTM(404.56,",DLAYGO=404.56,DIC(0)="L",X=SCTEAM,DIC("DR")=".02////^S X=SCLINK"
  1.  D FILE^DICN
  1.  Q
  1.  ;
  1. DELETE(SCLINKI) ; -- delete an autolink from a Team
  1.  N DIK,DA
  1.  IF $D(^SCTM(404.56,SCLINKI,0)) D
  1.  . S DIK="^SCTM(404.56,",DA=SCLINKI D ^DIK
  1.  Q
  1.  ;
  1. GETEAM(SCTEAM) ; -- retrieve Team demographics
  1.  Q $G(^SCTM(404.51,+$G(SCTEAM),0))
  1.  ;
  1. SCAN(SCTEAM,SC) ; -- build an array of current autolink assignments
  1.  N SCLINK
  1.  S SCLINK=""
  1.  F  S SCLINK=$O(^SCTM(404.56,"APRIMARY",+$G(SCTEAM),SCLINK)) Q:SCLINK=""  S SC(SCLINK)=+$O(^(SCLINK,0))
  1.  Q
  1.  ;
  1. ROOT(SCTYPE,SCROOT,SCGLB) ; -- determine global root of autolink type
  1.  S (SCROOT,SCGLB)=""
  1.  IF SCTYPE="WARD" S SCROOT="DIC(42,",SCGLB="^DIC(42)"
  1.  IF SCTYPE="SPECIALTY" S SCROOT="DIC(45.7,",SCGLB="^DIC(45.7)"
  1.  IF SCTYPE="PRACTITIONER" S SCROOT="VA(200,",SCGLB="^VA(200)"
  1.  IF SCTYPE="ROOM" S SCROOT="DG(405.4,",SCGLB="^DG(405.4)"
  1.  IF SCTYPE="CLINIC" S SCROOT="SC(",SCGLB="^SC"
  1.  Q
  1.  ;
  1.  ;  input:  SCTYPE   := type of autolink (WARD, SPECIALTY, ectc.)
  1.  ;          SCIEN    := ien of entity
  1.  ; output:  SC(1..n) := list of Team names autolinked to entity
  1.  ;                    
  1.  ;
  1.  N SCTEAM,SCROOT,SCGLB,SCINC,SCLINK
  1.  ; -- deterine global root for autolink entity
  1.  D ROOT(SCTYPE,.SCROOT,.SCGLB)
  1.  ; -- set variable pointer value for autolink entity
  1.  S SCLINK=+SCIEN_";"_$G(SCROOT)
  1.  ; -- find Teams with autolinks to this entity
  1.  S (SCINC,SCTEAM)=0
  1.  IF $O(^SCTM(404.56,"AC",SCLINK,SCTEAM)) D
  1.  . F  S SCTEAM=$O(^SCTM(404.56,"AC",SCLINK,SCTEAM)) Q:'SCTEAM  D
  1.  . . S SCINC=SCINC+1
  1.  . . S SC(SCINC)=$P($G(^SCTM(404.51,SCTEAM,0)),U)
  1.  ELSE  D
  1.  . S SCINC=SCINC+1
  1.  . S SC(SCINC)="No links found."
  1.  Q
  1.  ;
  1. PCPROV(SCTP,DATE,PCAP) ;returns ien & name of practitioner filling position
  1.  ;Input: SCTP=team position ifn of primary care position assignment
  1.  ;Input: DATE=relevant date
  1.  ;Input: PCAP= '1' for pc provider
  1.  ;             '2' for attending provider
  1.  ;             '3' for pc associate provider
  1.  ;
  1.  ;   Returned [Error or None Found:"", Else: sc200^practname]
  1.  ;
  1.  N X,SCPRDTS,SCPR,SCPP,ERR,SCI,SCII,SCPRX,SCSUB,SCX,SCY
  1.  S SCPP=0,DATE=$G(DATE,DT),SCPRDTS("INCL")=0
  1.  S (SCPRDTS("BEGIN"),SCPRDTS("END"))=DATE
  1.  ;bp/cmf 204 original code next line [SCALLHIS param not needed]
  1.  ;S X=$$PRTPC^SCAPMC(SCTP,"SCPRDTS","SCPR","ERR",1,0)
  1.  ;bp/cmf 204 change code next line
  1.  S X=$$PRTPC^SCAPMC(SCTP,"SCPRDTS","SCPR","ERR",0,0)
  1.  ;regroup providers
  1.  S SCI=0 F  S SCI=$O(SCPR(SCI)) Q:'SCI  D
  1.  .S SCSUB="" F  S SCSUB=$O(SCPR(SCI,SCSUB)) Q:SCSUB=""  D
  1.  ..I SCSUB="PREC" S SCPP=1 Q:PCAP=3  ;precepted position flag
  1.  ..S SCII="" F  S SCII=$O(SCPR(SCI,SCSUB,SCII)) Q:SCII=""  D
  1.  ...S SCX=$P(SCPR(SCI,SCSUB,SCII),U,1,2) Q:'SCX
  1.  ...S SCY=$S(PCAP=2:$P(SCSUB,"-"),1:SCSUB)
  1.  ...S SCPRX(SCY)=$G(SCPRX(SCY))+1,SCPRX(SCY,SCPRX(SCY))=SCX
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  ;return preceptor pc provider
  1.  I PCAP=1,SCPP,$G(SCPRX("PREC"))=1 Q SCPRX("PREC",1)
  1.  ;return non-preceptor pc provider
  1.  I PCAP=1,'SCPP,$G(SCPRX("PROV-U"))=1 Q SCPRX("PROV-U",1)
  1.  ;return attending provider
  1.  I PCAP=2,$G(SCPRX("PROV"))=1 Q SCPRX("PROV",1)
  1.  ;return associate provider
  1.  I PCAP=3,SCPP,$G(SCPRX("PROV-P"))=1 Q SCPRX("PROV-P",1)
  1.  ;bp/cmf 204 original code next line [-1 busts documented output]
  1.  ;Q -1
  1.  ;bp/cmf 204 change code next line ["" is documented output]
  1.  Q ""