SCAPMCA1.m

SCAPMCA1 ;BP-CIOFO/KEITH - Get all assignment info. (cont.) ; 30 Jul 99  3:29 PM

 ;;5.3;Scheduling;**177,1015**;AUG 13, 1993;Build 21

 ;

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

SCAPMCA1  ;BP-CIOFO/KEITH - Get all assignment info. (cont.) ; 30 Jul 99  3:29 PM

 +1       ;;5.3;Scheduling;**177,1015**;AUG 13, 1993;Build 21

 +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