SCAPMCA1 ;BP-CIOFO/KEITH - Get all assignment info. (cont.) ; 30 Jul 99 3:29 PM
;;5.3;Scheduling;**177**;AUG 13, 1993
;
GETDAT ;Get assignment data
;
GETTM ;Get team information
S SCI=$$TMPT^SCAPMC(DFN,.SCDT,,SCRATCH1)
S SCI=0 F S SCI=$O(^TMP("SCRATCH1",$J,SCI)) Q:'SCI D
.S SCTMD=^TMP("SCRATCH1",$J,SCI),SCTM=+SCTMD,SCPTA=+$P(SCTMD,U,3)
.Q:SCTM'>0 ;invalid TEAM ifn
.Q:SCPTA'>0 ;invalid PATIENT TEAM ASSIGNMENT ifn
.S @SCARR@(DFN,"TM",SCTM,SCPTA)=SCTMD
.Q
K @SCRATCH1
;
GETPOS ;Get position information
S SCI=$$TPPT^SCAPMC(DFN,.SCDT,,,,,,SCRATCH1)
S SCI=0 F S SCI=$O(^TMP("SCRATCH1",$J,SCI)) Q:'SCI D
.S SCPOSD=^TMP("SCRATCH1",$J,SCI)
.S SCTM=$P(SCPOSD,U,3),SCPTPA=$P(SCPOSD,U,4),SCPOS=+SCPOSD
.Q:SCPOS'>0 ;invalid TEAM POSITION ifn
.Q:SCTM'>0 ;invalid TEAM ifn
.Q:SCPTPA'>0 ;invalid PATIENT TEAM POSITION ASSIGNMENT ifn
.S SCPTPA0=$G(^SCPT(404.43,SCPTPA,0))
.S SCPTA=+SCPTPA0,SCPCPOSF=$P(SCPTPA0,U,5)
.Q:SCPTA'>0 ;invalid PATIENT TEAM ASSIGNMENT ifn
.S @SCARR@(DFN,"TM",SCTM,SCPTA,"POS",SCPTPA)=SCPOSD
.D SETF(SCPCPOSF,"POS",SCPOSD)
.S SCADT=$P(SCPOSD,U,5) ;position activate date
.S:'SCADT SCADT=SCDT("BEGIN")
.S SCIDT=$P(SCPOSD,U,6) ;position inactivate date
.S:'SCIDT SCIDT=SCDT("END")
.;xref team pc position assignments
.I SCPCPOSF S @SCARR@(DFN,"TM",SCTM,SCPTA,"PC",SCADT,SCIDT)=""
.K SCDT2 D DTRADJ(SCADT,SCIDT,.SCDT,.SCDT2)
.;
.;Get provider information
.K @SCRATCH2
.S SCII=$$PRTPC^SCAPMC(SCPOS,.SCDT2,SCRATCH2,"ERR",1,1),SCII=0
.F S SCII=$O(^TMP("SCRATCH2",$J,SCII)) Q:'SCII D
..F SCSUB="PROV-U","PROV-P" S SCIII="" D
...F S SCIII=$O(^TMP("SCRATCH2",$J,SCII,SCSUB,SCIII)) Q:SCIII="" D
....S SCPRD=^TMP("SCRATCH2",$J,SCII,SCSUB,SCIII)
....S SCPAH=+$P(SCPRD,U,11) ;position assignment history ifn
....S @SCARR@(DFN,"TM",SCTM,SCPTA,"POS",SCPTPA,"PROV",SCPAH)=SCPRD
....D SETF(SCPCPOSF,$S(SCSUB="PROV-P"&SCPCPOSF:"AP",1:"PR"),SCPRD)
....Q
...Q
..S SCIII=""
..F S SCIII=$O(^TMP("SCRATCH2",$J,SCII,"PREC",SCIII)) Q:SCIII="" D
...S SCPRD=^TMP("SCRATCH2",$J,SCII,"PREC",SCIII)
...S SCPPOS=+$P(SCPRD,U,3),SCPPOSD=$$PPOS(SCPRD,SCPPOS)
...S @SCARR@(DFN,"TM",SCTM,SCPTA,"POS",SCPTPA,"PPOS",SCPPOS)=SCPPOSD
...D SETF(SCPCPOSF,"PPOS",SCPPOSD) S SCPAH=+$P(SCPRD,U,11)
...S @SCARR@(DFN,"TM",SCTM,SCPTA,"POS",SCPTPA,"PPOS",SCPPOS,"PPROV",SCPAH)=SCPRD
...D SETF(SCPCPOSF,$S(SCPCPOSF:"PR",1:"PPR"),SCPRD)
...Q
..Q
.Q
;Set team "flat" nodes
S SCTM=0 F S SCTM=$O(@SCARR@(DFN,"TM",SCTM)) Q:'SCTM S SCPTA=0 D
.F S SCPTA=$O(@SCARR@(DFN,"TM",SCTM,SCPTA)) Q:'SCPTA D
..S SCTMD=$G(@SCARR@(DFN,"TM",SCTM,SCPTA)) Q:'$L(SCTMD)
..D SETF($P(SCTMD,U,8)=1,"TM",SCTMD)
..Q
.Q
Q
;
GAP(SCTAC,SCTINAC,SCADT,SCIDT) ;Determine if a gap exists in pc assignments
N GAP
S GAP=0 D G1(SCADT,SCIDT)
Q GAP
;
G1(SCADT,SCIDT) ;Loop through position assignments
N X1,X2,X
S SCADT=$O(@SCARR@(DFN,"TM",SCTM,SCPTA,"PC",SCIDT-1))
I 'SCADT S GAP=(SCIDT<SCTINAC) Q
S X1=SCADT,X2=SCIDT D ^%DTC I X>1 S GAP=1 Q
S SCIDT=$O(@SCARR@(DFN,"TM",SCTM,SCPTA,"PC",SCADT,""),-1)
I SCIDT'<SCTINAC Q
D G1(SCADT,SCIDT) Q
;
PPOS(SCSTR,SCPPOS) ;Get preceptor position information
;Input: SCSTR=preceptor data string from PRTP^SCAPMC
;Input: SCPPOS=preceptor TEAM POSITION ifn
;Output: position information data string as defined in ^SCAPMCA
;
N SCX,SCI,SCPPOS0
S SCPPOS0=$G(^SCTM(404.57,+SCPPOS,0))
Q:'$L(SCPPOS0) ""
S SCX(1)=SCPPOS ;position ifn
S SCX(2)=$P(SCPPOS0,U) ;position name
S SCX(3)=$P(SCPPOS0,U,2) ;team ifn
S SCX(4)=$P(SCPOSD,U,4) ;patient team position assignment ifn
S SCX(5)=$P(SCSTR,U,5) ;effective date
S SCX(6)=$P(SCSTR,U,6) ;inactive date
S SCX(7)=$P(SCPPOS0,U,3) ;role ifn
S SCX(8)=$P($G(^SD(403.46,+SCX(7),0)),U) ;role name
S SCX(9)=$P(SCPPOS0,U,13) ;user class ifn
S SCX(10)=$P($G(^USR(8930,+SCX(9),0)),U) ;user class name
S SCX(11)=$P(SCPOSD,U,11) ;patient team assignment ifn
S SCX(12)="" ;preceptor position
S SCX="" F SCI=1:1:12 S $P(SCX,U,SCI)=SCX(SCI)
Q SCX
;
DTRADJ(ADT,IDT,SCDT,SCDT2) ;Adjust dates for provider information
;Input: ADT=activate date for patient team position assignment
;Input: IDT=inactivate date for patient team position assignment
;Input: SCDT=array of dates from calling program (pass by reference)
;Input: SCDT2=array to return adjusted dates (pass by reference)
;
S SCDT2("BEGIN")=$S(SCADT>SCDT("BEGIN"):SCADT,1:SCDT("BEGIN"))
S SCDT2("END")=$S('SCIDT:SCDT("END"),SCIDT<SCDT("END"):SCIDT,1:SCDT("END"))
S SCDT2("INCL")=SCDT("INCL"),SCDT2="SCDT2"
Q
;
SETF(SCPC,SUB,DATA) ;Set "flat" array node
;Input: SCPC=PC/NPC flag
;Input: SUB=subscript value
;Input: DATA=data string
N X,CT
S X=$S(SCPC>0:"PC",1:"NPC"),SUB=X_SUB
S @SCARR@(DFN,SUB,0)=@SCARR@(DFN,SUB,0)+1
S CT=@SCARR@(DFN,SUB,0),@SCARR@(DFN,SUB,CT)=DATA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCAPMCA1 4880 printed Apr 09, 2024@21:54:10 Page 2
SCAPMCA1 ;BP-CIOFO/KEITH - Get all assignment info. (cont.) ; 30 Jul 99 3:29 PM
+1 ;;5.3;Scheduling;**177**;AUG 13, 1993
+2 ;
GETDAT ;Get assignment data
+1 ;
GETTM ;Get team information
+1 SET SCI=$$TMPT^SCAPMC(DFN,.SCDT,,SCRATCH1)
+2 SET SCI=0
FOR
SET SCI=$ORDER(^TMP("SCRATCH1",$JOB,SCI))
if 'SCI
QUIT
Begin DoDot:1
+3 SET SCTMD=^TMP("SCRATCH1",$JOB,SCI)
SET SCTM=+SCTMD
SET SCPTA=+$PIECE(SCTMD,U,3)
+4 ;invalid TEAM ifn
if SCTM'>0
QUIT
+5 ;invalid PATIENT TEAM ASSIGNMENT ifn
if SCPTA'>0
QUIT
+6 SET @SCARR@(DFN,"TM",SCTM,SCPTA)=SCTMD
+7 QUIT
End DoDot:1
+8 KILL @SCRATCH1
+9 ;
GETPOS ;Get position information
+1 SET SCI=$$TPPT^SCAPMC(DFN,.SCDT,,,,,,SCRATCH1)
+2 SET SCI=0
FOR
SET SCI=$ORDER(^TMP("SCRATCH1",$JOB,SCI))
if 'SCI
QUIT
Begin DoDot:1
+3 SET SCPOSD=^TMP("SCRATCH1",$JOB,SCI)
+4 SET SCTM=$PIECE(SCPOSD,U,3)
SET SCPTPA=$PIECE(SCPOSD,U,4)
SET SCPOS=+SCPOSD
+5 ;invalid TEAM POSITION ifn
if SCPOS'>0
QUIT
+6 ;invalid TEAM ifn
if SCTM'>0
QUIT
+7 ;invalid PATIENT TEAM POSITION ASSIGNMENT ifn
if SCPTPA'>0
QUIT
+8 SET SCPTPA0=$GET(^SCPT(404.43,SCPTPA,0))
+9 SET SCPTA=+SCPTPA0
SET SCPCPOSF=$PIECE(SCPTPA0,U,5)
+10 ;invalid PATIENT TEAM ASSIGNMENT ifn
if SCPTA'>0
QUIT
+11 SET @SCARR@(DFN,"TM",SCTM,SCPTA,"POS",SCPTPA)=SCPOSD
+12 DO SETF(SCPCPOSF,"POS",SCPOSD)
+13 ;position activate date
SET SCADT=$PIECE(SCPOSD,U,5)
+14 if 'SCADT
SET SCADT=SCDT("BEGIN")
+15 ;position inactivate date
SET SCIDT=$PIECE(SCPOSD,U,6)
+16 if 'SCIDT
SET SCIDT=SCDT("END")
+17 ;xref team pc position assignments
+18 IF SCPCPOSF
SET @SCARR@(DFN,"TM",SCTM,SCPTA,"PC",SCADT,SCIDT)=""
+19 KILL SCDT2
DO DTRADJ(SCADT,SCIDT,.SCDT,.SCDT2)
+20 ;
+21 ;Get provider information
+22 KILL @SCRATCH2
+23 SET SCII=$$PRTPC^SCAPMC(SCPOS,.SCDT2,SCRATCH2,"ERR",1,1)
SET SCII=0
+24 FOR
SET SCII=$ORDER(^TMP("SCRATCH2",$JOB,SCII))
if 'SCII
QUIT
Begin DoDot:2
+25 FOR SCSUB="PROV-U","PROV-P"
SET SCIII=""
Begin DoDot:3
+26 FOR
SET SCIII=$ORDER(^TMP("SCRATCH2",$JOB,SCII,SCSUB,SCIII))
if SCIII=""
QUIT
Begin DoDot:4
+27 SET SCPRD=^TMP("SCRATCH2",$JOB,SCII,SCSUB,SCIII)
+28 ;position assignment history ifn
SET SCPAH=+$PIECE(SCPRD,U,11)
+29 SET @SCARR@(DFN,"TM",SCTM,SCPTA,"POS",SCPTPA,"PROV",SCPAH)=SCPRD
+30 DO SETF(SCPCPOSF,$SELECT(SCSUB="PROV-P"&SCPCPOSF:"AP",1:"PR"),SCPRD)
+31 QUIT
End DoDot:4
+32 QUIT
End DoDot:3
+33 SET SCIII=""
+34 FOR
SET SCIII=$ORDER(^TMP("SCRATCH2",$JOB,SCII,"PREC",SCIII))
if SCIII=""
QUIT
Begin DoDot:3
+35 SET SCPRD=^TMP("SCRATCH2",$JOB,SCII,"PREC",SCIII)
+36 SET SCPPOS=+$PIECE(SCPRD,U,3)
SET SCPPOSD=$$PPOS(SCPRD,SCPPOS)
+37 SET @SCARR@(DFN,"TM",SCTM,SCPTA,"POS",SCPTPA,"PPOS",SCPPOS)=SCPPOSD
+38 DO SETF(SCPCPOSF,"PPOS",SCPPOSD)
SET SCPAH=+$PIECE(SCPRD,U,11)
+39 SET @SCARR@(DFN,"TM",SCTM,SCPTA,"POS",SCPTPA,"PPOS",SCPPOS,"PPROV",SCPAH)=SCPRD
+40 DO SETF(SCPCPOSF,$SELECT(SCPCPOSF:"PR",1:"PPR"),SCPRD)
+41 QUIT
End DoDot:3
+42 QUIT
End DoDot:2
+43 QUIT
End DoDot:1
+44 ;Set team "flat" nodes
+45 SET SCTM=0
FOR
SET SCTM=$ORDER(@SCARR@(DFN,"TM",SCTM))
if 'SCTM
QUIT
SET SCPTA=0
Begin DoDot:1
+46 FOR
SET SCPTA=$ORDER(@SCARR@(DFN,"TM",SCTM,SCPTA))
if 'SCPTA
QUIT
Begin DoDot:2
+47 SET SCTMD=$GET(@SCARR@(DFN,"TM",SCTM,SCPTA))
if '$LENGTH(SCTMD)
QUIT
+48 DO SETF($PIECE(SCTMD,U,8)=1,"TM",SCTMD)
+49 QUIT
End DoDot:2
+50 QUIT
End DoDot:1
+51 QUIT
+52 ;
GAP(SCTAC,SCTINAC,SCADT,SCIDT) ;Determine if a gap exists in pc assignments
+1 NEW GAP
+2 SET GAP=0
DO G1(SCADT,SCIDT)
+3 QUIT GAP
+4 ;
G1(SCADT,SCIDT) ;Loop through position assignments
+1 NEW X1,X2,X
+2 SET SCADT=$ORDER(@SCARR@(DFN,"TM",SCTM,SCPTA,"PC",SCIDT-1))
+3 IF 'SCADT
SET GAP=(SCIDT<SCTINAC)
QUIT
+4 SET X1=SCADT
SET X2=SCIDT
DO ^%DTC
IF X>1
SET GAP=1
QUIT
+5 SET SCIDT=$ORDER(@SCARR@(DFN,"TM",SCTM,SCPTA,"PC",SCADT,""),-1)
+6 IF SCIDT'<SCTINAC
QUIT
+7 DO G1(SCADT,SCIDT)
QUIT
+8 ;
PPOS(SCSTR,SCPPOS) ;Get preceptor position information
+1 ;Input: SCSTR=preceptor data string from PRTP^SCAPMC
+2 ;Input: SCPPOS=preceptor TEAM POSITION ifn
+3 ;Output: position information data string as defined in ^SCAPMCA
+4 ;
+5 NEW SCX,SCI,SCPPOS0
+6 SET SCPPOS0=$GET(^SCTM(404.57,+SCPPOS,0))
+7 if '$LENGTH(SCPPOS0)
QUIT ""
+8 ;position ifn
SET SCX(1)=SCPPOS
+9 ;position name
SET SCX(2)=$PIECE(SCPPOS0,U)
+10 ;team ifn
SET SCX(3)=$PIECE(SCPPOS0,U,2)
+11 ;patient team position assignment ifn
SET SCX(4)=$PIECE(SCPOSD,U,4)
+12 ;effective date
SET SCX(5)=$PIECE(SCSTR,U,5)
+13 ;inactive date
SET SCX(6)=$PIECE(SCSTR,U,6)
+14 ;role ifn
SET SCX(7)=$PIECE(SCPPOS0,U,3)
+15 ;role name
SET SCX(8)=$PIECE($GET(^SD(403.46,+SCX(7),0)),U)
+16 ;user class ifn
SET SCX(9)=$PIECE(SCPPOS0,U,13)
+17 ;user class name
SET SCX(10)=$PIECE($GET(^USR(8930,+SCX(9),0)),U)
+18 ;patient team assignment ifn
SET SCX(11)=$PIECE(SCPOSD,U,11)
+19 ;preceptor position
SET SCX(12)=""
+20 SET SCX=""
FOR SCI=1:1:12
SET $PIECE(SCX,U,SCI)=SCX(SCI)
+21 QUIT SCX
+22 ;
DTRADJ(ADT,IDT,SCDT,SCDT2) ;Adjust dates for provider information
+1 ;Input: ADT=activate date for patient team position assignment
+2 ;Input: IDT=inactivate date for patient team position assignment
+3 ;Input: SCDT=array of dates from calling program (pass by reference)
+4 ;Input: SCDT2=array to return adjusted dates (pass by reference)
+5 ;
+6 SET SCDT2("BEGIN")=$SELECT(SCADT>SCDT("BEGIN"):SCADT,1:SCDT("BEGIN"))
+7 SET SCDT2("END")=$SELECT('SCIDT:SCDT("END"),SCIDT<SCDT("END"):SCIDT,1:SCDT("END"))
+8 SET SCDT2("INCL")=SCDT("INCL")
SET SCDT2="SCDT2"
+9 QUIT
+10 ;
SETF(SCPC,SUB,DATA) ;Set "flat" array node
+1 ;Input: SCPC=PC/NPC flag
+2 ;Input: SUB=subscript value
+3 ;Input: DATA=data string
+4 NEW X,CT
+5 SET X=$SELECT(SCPC>0:"PC",1:"NPC")
SET SUB=X_SUB
+6 SET @SCARR@(DFN,SUB,0)=@SCARR@(DFN,SUB,0)+1
+7 SET CT=@SCARR@(DFN,SUB,0)
SET @SCARR@(DFN,SUB,CT)=DATA
+8 QUIT
