source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMCU3.m@ 1710

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