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 ""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCAPMCU3 5702 printed Apr 09, 2024@21:47:01 Page 2
SCAPMCU3 ;MJK/ALB - AUTOLINK API ; 8/10/99 4:09pm
+1 ;;5.3;Scheduling;**41,45,177,204**;AUG 13, 1993
+2 ;
GETREC(SCDATA,SCTEAM) ; -- get team record with autolink data
+1 ; input : SCTEAM := ien of team
+2 ; output : SCDATA is the return array
+3 ; SCDATA(0) := 0th node of Team
+4 ; (1..n) := autolink name ^ autolink type ^ ien of entity
+5 ;
+6 NEW SC,X
+7 ; -- get 0th node of team
+8 SET X=$$GETEAM(SCTEAM)
+9 ; -- add to return array
+10 DO SET(X,0,.SCDATA)
+11 ; -- find all autolinks for team
+12 DO SCAN(SCTEAM,.SC)
+13 ; -- build autolink string and add to return array
+14 DO BUILD(.SC,.SCDATA)
+15 QUIT
+16 ;
BUILD(SC,SCDATA) ; -- build string to send and add to return array
+1 NEW SCLINK,SCINC,X,SCGLB,SCTYPE
+2 SET SCINC=1
+3 SET SCLINK=""
+4 FOR
SET SCLINK=$ORDER(SC(SCLINK))
if SCLINK=""
QUIT
Begin DoDot:1
+5 SET X=SCLINK
+6 IF X["DIC(42,"
SET SCGLB="^DIC(42)"
SET SCTYPE="WARD"
+7 IF X["DIC(45.7,"
SET SCGLB="^DIC(45.7)"
SET SCTYPE="SPECIALTY"
+8 IF X["VA(200,"
SET SCGLB="^VA(200)"
SET SCTYPE="PRACTITIONER"
+9 IF X["DG(405.4,"
SET SCGLB="^DG(405.4)"
SET SCTYPE="ROOM"
+10 IF X["SC("
SET SCGLB="^SC"
SET SCTYPE="CLINIC"
+11 ; - add data to return array
+12 IF $DATA(@SCGLB@(+SCLINK,0))
DO SET($PIECE(^(0),U)_U_SCTYPE_U_+SCLINK,.SCINC,.SCDATA)
End DoDot:1
+13 QUIT
+14 ;
SET(X,INC,SCDATA) ; -- set value in return array
+1 SET INC=$GET(INC)+1
SET SCDATA(INC)=X
+2 QUIT
+3 ;
SETREC(SCOK,SCTEAM,SC) ; -- add/edit autolink data to Team record
+1 ; input : SCTEAM := ien of team
+2 ; output : SC is the input array
+3 ; SC(1..n) := autolink name ^ autolink type ^ ien of entity
+4 ;
+5 NEW SCTYPE,SCROOT,SCGLB,SCLINK,SCLINKI,SCI,SCOLD,SCNEW
+6 ; -- build array of current autolink assignments
+7 DO SCAN(SCTEAM,.SCOLD)
+8 ;
+9 ; -- compare current with input and add autolinks if in
+10 ; input array but not in current array
+11 SET SCI=0
FOR
SET SCI=$ORDER(SC(SCI))
if 'SCI
QUIT
SET SCX=SC(SCI)
Begin DoDot:1
+12 SET SCTYPE=$PIECE(SCX,U,2)
+13 DO ROOT(SCTYPE,.SCROOT,.SCGLB)
+14 SET SCLINK=+$PIECE(SCX,U,3)_";"_SCROOT
+15 SET SCNEW(SCLINK)=""
+16 IF '$DATA(SCOLD(SCLINK))
IF SCGLB]""
IF $DATA(@SCGLB@(+SCLINK,0))
DO ADD(SCTEAM,SCLINK)
End DoDot:1
+17 ;
+18 ; -- compare current with input and delete autolinks if not
+19 ; in input array but in current array
+20 SET SCLINK=""
+21 FOR
SET SCLINK=$ORDER(SCOLD(SCLINK))
if 'SCLINK
QUIT
IF '$DATA(SCNEW(SCLINK))
Begin DoDot:1
+22 SET SCLINKI=+SCOLD(SCLINK)
+23 IF SCLINKI
DO DELETE(SCLINKI)
End DoDot:1
+24 SET SCOK=1
+25 QUIT
+26 ;
ADD(SCTEAM,SCLINK) ; -- add an autolink to a Team
+1 NEW DIC,DD,DO,DLAYGO
+2 SET DIC="^SCTM(404.56,"
SET DLAYGO=404.56
SET DIC(0)="L"
SET X=SCTEAM
SET DIC("DR")=".02////^S X=SCLINK"
+3 DO FILE^DICN
+4 QUIT
+5 ;
DELETE(SCLINKI) ; -- delete an autolink from a Team
+1 NEW DIK,DA
+2 IF $DATA(^SCTM(404.56,SCLINKI,0))
Begin DoDot:1
+3 SET DIK="^SCTM(404.56,"
SET DA=SCLINKI
DO ^DIK
End DoDot:1
+4 QUIT
+5 ;
GETEAM(SCTEAM) ; -- retrieve Team demographics
+1 QUIT $GET(^SCTM(404.51,+$GET(SCTEAM),0))
+2 ;
SCAN(SCTEAM,SC) ; -- build an array of current autolink assignments
+1 NEW SCLINK
+2 SET SCLINK=""
+3 FOR
SET SCLINK=$ORDER(^SCTM(404.56,"APRIMARY",+$GET(SCTEAM),SCLINK))
if SCLINK=""
QUIT
SET SC(SCLINK)=+$ORDER(^(SCLINK,0))
+4 QUIT
+5 ;
ROOT(SCTYPE,SCROOT,SCGLB) ; -- determine global root of autolink type
+1 SET (SCROOT,SCGLB)=""
+2 IF SCTYPE="WARD"
SET SCROOT="DIC(42,"
SET SCGLB="^DIC(42)"
+3 IF SCTYPE="SPECIALTY"
SET SCROOT="DIC(45.7,"
SET SCGLB="^DIC(45.7)"
+4 IF SCTYPE="PRACTITIONER"
SET SCROOT="VA(200,"
SET SCGLB="^VA(200)"
+5 IF SCTYPE="ROOM"
SET SCROOT="DG(405.4,"
SET SCGLB="^DG(405.4)"
+6 IF SCTYPE="CLINIC"
SET SCROOT="SC("
SET SCGLB="^SC"
+7 QUIT
+8 ;
GETLINK(SC,SCTYPE,SCIEN) ; -- get autolink entity data
+1 ; input: SCTYPE := type of autolink (WARD, SPECIALTY, ectc.)
+2 ; SCIEN := ien of entity
+3 ; output: SC(1..n) := list of Team names autolinked to entity
+4 ;
+5 ;
+6 NEW SCTEAM,SCROOT,SCGLB,SCINC,SCLINK
+7 ; -- deterine global root for autolink entity
+8 DO ROOT(SCTYPE,.SCROOT,.SCGLB)
+9 ; -- set variable pointer value for autolink entity
+10 SET SCLINK=+SCIEN_";"_$GET(SCROOT)
+11 ; -- find Teams with autolinks to this entity
+12 SET (SCINC,SCTEAM)=0
+13 IF $ORDER(^SCTM(404.56,"AC",SCLINK,SCTEAM))
Begin DoDot:1
+14 FOR
SET SCTEAM=$ORDER(^SCTM(404.56,"AC",SCLINK,SCTEAM))
if 'SCTEAM
QUIT
Begin DoDot:2
+15 SET SCINC=SCINC+1
+16 SET SC(SCINC)=$PIECE($GET(^SCTM(404.51,SCTEAM,0)),U)
End DoDot:2
End DoDot:1
+17 IF '$TEST
Begin DoDot:1
+18 SET SCINC=SCINC+1
+19 SET SC(SCINC)="No links found."
End DoDot:1
+20 QUIT
+21 ;
PCPROV(SCTP,DATE,PCAP) ;returns ien & name of practitioner filling position
+1 ;Input: SCTP=team position ifn of primary care position assignment
+2 ;Input: DATE=relevant date
+3 ;Input: PCAP= '1' for pc provider
+4 ; '2' for attending provider
+5 ; '3' for pc associate provider
+6 ;
+7 ; Returned [Error or None Found:"", Else: sc200^practname]
+8 ;
+9 NEW X,SCPRDTS,SCPR,SCPP,ERR,SCI,SCII,SCPRX,SCSUB,SCX,SCY
+10 SET SCPP=0
SET DATE=$GET(DATE,DT)
SET SCPRDTS("INCL")=0
+11 SET (SCPRDTS("BEGIN"),SCPRDTS("END"))=DATE
+12 ;bp/cmf 204 original code next line [SCALLHIS param not needed]
+13 ;S X=$$PRTPC^SCAPMC(SCTP,"SCPRDTS","SCPR","ERR",1,0)
+14 ;bp/cmf 204 change code next line
+15 SET X=$$PRTPC^SCAPMC(SCTP,"SCPRDTS","SCPR","ERR",0,0)
+16 ;regroup providers
+17 SET SCI=0
FOR
SET SCI=$ORDER(SCPR(SCI))
if 'SCI
QUIT
Begin DoDot:1
+18 SET SCSUB=""
FOR
SET SCSUB=$ORDER(SCPR(SCI,SCSUB))
if SCSUB=""
QUIT
Begin DoDot:2
+19 ;precepted position flag
IF SCSUB="PREC"
SET SCPP=1
if PCAP=3
QUIT
+20 SET SCII=""
FOR
SET SCII=$ORDER(SCPR(SCI,SCSUB,SCII))
if SCII=""
QUIT
Begin DoDot:3
+21 SET SCX=$PIECE(SCPR(SCI,SCSUB,SCII),U,1,2)
if 'SCX
QUIT
+22 SET SCY=$SELECT(PCAP=2:$PIECE(SCSUB,"-"),1:SCSUB)
+23 SET SCPRX(SCY)=$GET(SCPRX(SCY))+1
SET SCPRX(SCY,SCPRX(SCY))=SCX
+24 QUIT
End DoDot:3
+25 QUIT
End DoDot:2
+26 QUIT
End DoDot:1
+27 ;return preceptor pc provider
+28 IF PCAP=1
IF SCPP
IF $GET(SCPRX("PREC"))=1
QUIT SCPRX("PREC",1)
+29 ;return non-preceptor pc provider
+30 IF PCAP=1
IF 'SCPP
IF $GET(SCPRX("PROV-U"))=1
QUIT SCPRX("PROV-U",1)
+31 ;return attending provider
+32 IF PCAP=2
IF $GET(SCPRX("PROV"))=1
QUIT SCPRX("PROV",1)
+33 ;return associate provider
+34 IF PCAP=3
IF SCPP
IF $GET(SCPRX("PROV-P"))=1
QUIT SCPRX("PROV-P",1)
+35 ;bp/cmf 204 original code next line [-1 busts documented output]
+36 ;Q -1
+37 ;bp/cmf 204 change code next line ["" is documented output]
+38 QUIT ""
