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

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