SCRPV1A ; bp/djb - PCMM Inconsistency Rpt - Get Data ; 8/25/99 9:57am
;;5.3;Scheduling;**177,528**;AUG 13, 1993;Build 4
;
;Return:
; Inconsistency array in format:
; ^TMP("PCMM POSITION",$J,#,Tm,TmPos,)=""
; ^TMP("PCMM PATIENT",$J,Name,DFN,#,Tm,Pos)=""
;
;For a list of inconsistencies, see bottom of routine SCRPV1B.
;
EN ;
D POSITION
D PATIENT
Q
;
POSITION ;Check for position inconsistencies.
;
NEW POSI,POSN,TMI,TMN
;
;Look at each team
S TMN=""
F S TMN=$O(^SCTM(404.51,"B",TMN)) Q:TMN="" D ;
. S TMI=0
. F S TMI=$O(^SCTM(404.51,"B",TMN,TMI)) Q:'TMI D ;
.. Q:'$D(^SCTM(404.51,TMI,0))
.. ;If user selected teams, quit if this one isn't on list.
.. I SCTYPE("TM")="S" Q:'$D(SCTM(TMI))
.. ;Look at each position for this team
.. S POSI=0
.. F S POSI=$O(^SCTM(404.57,"C",TMI,POSI)) Q:'POSI D ;
... S POSN=$P($G(^SCTM(404.57,POSI,0)),U,1) Q:POSN']""
... D CHECK45(TMI,POSI) ;..Check for inconsistencies 4 & 5.
... Q:'$D(^SCPT(404.43,"APTPA",POSI))
... D CHECK1(TMI,POSI) ;...Check for inconsistency 1.
Q
;
PATIENT ;Check for patient inconsistencies.
D CHECK28
D CHECK367
Q
;
CHECK1(TMI,POSI) ;Check positions for inconsistency 1.
;Input:
; TMI - Team IEN
; POSI - Team Position IEN
;
NEW POSN,TMN
Q:+$$GETPRTP^SCAPMCU2(POSI,DT) ;Current provider. Fld 304 in 404.57.
Q:+$$ACTTM^SCMCTMU(TMI,DT)'=1 ;Team inactive
Q:+$$ACTTP^SCMCTPU(POSI,DT)'=1 ;Position inactive
S TMN=$$TMNAME(TMI)
S POSN=$$POSNAME(POSI)
S ^TMP("PCMM POSITION",$J,1,TMN,POSN)="" ;.........................#1
Q
;
CHECK28 ;Check patients for inconsistencies 2 & 8.
;
;Loop thru 404.43 for each patient.
;Use "ACTDFN" xref. Active entries sorted by patient IEN.
;
NEW DATA,DFN,DFNNAM,NUM,POSI,POSN,PTI,PTPI,TMI,TMN
;
S DFN=0
F S DFN=$O(^SCPT(404.43,"ACTDFN",DFN)) Q:'DFN D ;
. S PTPI=0
. F S PTPI=$O(^SCPT(404.43,"ACTDFN",DFN,PTPI)) Q:'PTPI D ;
.. S DATA=$G(^SCPT(404.43,PTPI,0)) ;Team Position Assign zero node
.. Q:$P(DATA,U,4)]"" ;.............Inactive
.. S PTI=$P(DATA,U,1) Q:'PTI ;.....Team Assign IEN
.. S POSI=$P(DATA,U,2) Q:'POSI ;...Position
.. S DATA=$G(^SCPT(404.42,PTI,0)) ;.Team Assign zero node
.. S TMI=$P(DATA,U,3) Q:'TMI ;.....Team IEN
.. ;
.. ;If user selected teams, quit if this one isn't on list.
.. I SCTYPE("TM")="S" Q:'$D(SCTM(TMI))
.. ;
.. S POSN=$$POSNAME(POSI)
.. S TMN=$$TMNAME(TMI)
.. S DFNNAM=$$PTNAME(DFN) ;Patient name
.. ;
.. D ;Check for nconsistency 8
... I $P(DATA,U,9)]"" D ;...............Tm Pos Assign Inactive....#8
.... S ^TMP("PCMM PATIENT",$J,DFNNAM,DFN,8.1,TMN,POSN)=PTPI
... I +$$ACTTM^SCMCTMU(TMI,DT)'=1 D ;...Team inactive.............#8
.... S ^TMP("PCMM PATIENT",$J,DFNNAM,DFN,8.2,TMN,POSN)=PTPI
... I +$$ACTTP^SCMCTPU(POSI,DT)'=1 D ;..Position inactive.........#8
.... S ^TMP("PCMM PATIENT",$J,DFNNAM,DFN,8.3,TMN,POSN)=PTPI
.. ;
.. Q:$P(DATA,U,8)'=1 ;..Team Assign not PC
.. Q:$P(DATA,U,9)]"" ;..Team Assign inactive
.. ;
.. ;Q:$D(^SCPT(404.43,"APCPOS",DFN,1))
.. I $$GETPRTP^SCAPMCU2(POSI,DT)>0 Q ;sd/528
.. S ^TMP("PCMM PATIENT",$J,DFNNAM,DFN,2,TMN,POSN)=PTPI ;..........#2
Q
;
CHECK367 ;Check patients for inconsistencies 3,6,7.
;
;Loop thru 404.43 for each patient.
;Use "ACTPC" xref. Active entries sorted by patient IEN & PC ROLE.
;
NEW CNT,DATA,DFN,DFNNAM,HLD,POSI,POSN,PTI,PTPI,TMI,TMN
;
S DFN=0
F S DFN=$O(^SCPT(404.43,"ACTPC",DFN)) Q:'DFN D ;
. S CNT=0 KILL HLD ;Initialize for each DFN
. S PTPI=0
. F S PTPI=$O(^SCPT(404.43,"ACTPC",DFN,1,PTPI)) Q:'PTPI D ;
.. S DATA=$G(^SCPT(404.43,PTPI,0)) ;..Team Position Assign zero node
.. Q:$P(DATA,U,4)]"" ;...............Inactive
.. S PTI=$P(DATA,U,1) Q:'PTI ;.......Team Assign IEN
.. S POSI=$P(DATA,U,2) Q:'POSI ;.....Position
.. S DATA=$G(^SCPT(404.42,PTI,0)) ;...Team Assign zero node
.. S TMI=$P(DATA,U,3) Q:'TMI ;.......Team IEN
.. ;
.. ;If user selected teams, quit if this one isn't on list.
.. I SCTYPE("TM")="S" Q:'$D(SCTM(TMI))
.. ;
.. Q:$P(DATA,U,8)'=1 ;...............Team Assign not PC
.. Q:$P(DATA,U,9)]"" ;...............Team Assign inactive
.. S POSN=$$POSNAME(POSI)
.. S TMN=$$TMNAME(TMI)
.. S DFNNAM=$$PTNAME(DFN) ;Patient name
.. ;
.. D CHECK67
.. ;
.. S CNT=CNT+1
.. ;Save 1st occurance. Asingle occurance is not a problem.
.. I CNT=1 S HLD(DFNNAM,DFN,3,TMN,POSN)="" Q
.. ;
.. ;If there is a 2nd occurance, move 1st occurance into array.
.. I CNT=2 M ^TMP("PCMM PATIENT",$J)=HLD KILL HLD
.. S ^TMP("PCMM PATIENT",$J,DFNNAM,DFN,3,TMN,POSN)=PTPI ;..........#3
Q
;
CHECK45(TMI,POSI) ;Check positions for inconsistencies 4 & 5.
;Input:
; TMI - Team IEN
; POSI - Team Position IEN
;
NEW AP,DATA,PCP,POSN,PREHI,STAFFAP,STAFFPCP,TMN
;
S PREHI=0
F S PREHI=$O(^SCTM(404.53,"B",POSI,PREHI)) Q:'PREHI D ;
. S DATA=$G(^SCTM(404.53,PREHI,0))
. Q:DATA']""
. S AP=$P(DATA,U,1) ;.....................Preceptee position
. S PCP=$P(DATA,U,6) ;....................Preceptor position
. S STAFFAP=+$$GETPRTP^SCAPMCU2(AP,DT) ;..Preceptee staff person
. S STAFFPCP=+$$GETPRTP^SCAPMCU2(PCP,DT) ;Preceptor staff person
. ;
. S TMN=$$TMNAME(TMI)
. S POSN=$$POSNAME(POSI)
. I STAFFAP,STAFFAP=STAFFPCP D ;
.. S ^TMP("PCMM POSITION",$J,4,TMN,POSN)="" ;......................#4
. I STAFFPCP="" D ;
.. S ^TMP("PCMM POSITION",$J,5,TMN,POSN)="" ;......................#5
Q
;
CHECK67 ;Check patients for inconsistencies 6 & 7.
NEW ERROR,ID,LIST,NUM,POS,RESULT,TYPE,ZDATE
;
S ZDATE("BEGIN")=DT
S ZDATE("END")=DT
S ZDATE("INCL")=0
;
S RESULT=$$PRPTTPC^SCAPMC(PTPI,"ZDATE","LIST","ERROR",1)
;
S NUM=0
F S NUM=$O(LIST(NUM)) Q:'NUM D ;
. S TYPE=""
. F S TYPE=$O(LIST(NUM,TYPE)) Q:TYPE="" D ;
.. S ID=""
.. F S ID=$O(LIST(NUM,TYPE,ID)) Q:ID="" D ;
... S POS=$P(LIST(NUM,TYPE,ID),U,3) Q:'POS
... ;See if field 4, POSSIBLE PRIMARY PRACTITIONER, equals 1.
... Q:$P($G(^SCTM(404.57,POS,0)),U,4)=1
... I TYPE="AP" D Q
.... S ^TMP("PCMM PATIENT",$J,DFNNAM,DFN,6,TMN,POSN)=PTPI ;........#6
... I TYPE="PCP" D Q
.... S ^TMP("PCMM PATIENT",$J,DFNNAM,DFN,7,TMN,POSN)=PTPI ;........#7
Q
;
TMNAME(TMI) ;Return team name
NEW NAME
S NAME=$P($G(^SCTM(404.51,TMI,0)),U,1)
S:NAME="" NAME="UNKNOWN"
Q NAME
;
POSNAME(POSI) ;Return position name
NEW NAME
S NAME=$P($G(^SCTM(404.57,POSI,0)),U,1)
S:NAME="" NAME="UNKNOWN"
Q NAME
;
PTNAME(DFN) ;Return patient name
NEW NAME
S NAME=$P($G(^DPT(DFN,0)),U,1)
S:NAME="" NAME="UNKNOWN"
Q NAME
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPV1A 6624 printed Sep 23, 2025@20:19:33 Page 2
SCRPV1A ; bp/djb - PCMM Inconsistency Rpt - Get Data ; 8/25/99 9:57am
+1 ;;5.3;Scheduling;**177,528**;AUG 13, 1993;Build 4
+2 ;
+3 ;Return:
+4 ; Inconsistency array in format:
+5 ; ^TMP("PCMM POSITION",$J,#,Tm,TmPos,)=""
+6 ; ^TMP("PCMM PATIENT",$J,Name,DFN,#,Tm,Pos)=""
+7 ;
+8 ;For a list of inconsistencies, see bottom of routine SCRPV1B.
+9 ;
EN ;
+1 DO POSITION
+2 DO PATIENT
+3 QUIT
+4 ;
POSITION ;Check for position inconsistencies.
+1 ;
+2 NEW POSI,POSN,TMI,TMN
+3 ;
+4 ;Look at each team
+5 SET TMN=""
+6 ;
FOR
SET TMN=$ORDER(^SCTM(404.51,"B",TMN))
if TMN=""
QUIT
Begin DoDot:1
+7 SET TMI=0
+8 ;
FOR
SET TMI=$ORDER(^SCTM(404.51,"B",TMN,TMI))
if 'TMI
QUIT
Begin DoDot:2
+9 if '$DATA(^SCTM(404.51,TMI,0))
QUIT
+10 ;If user selected teams, quit if this one isn't on list.
+11 IF SCTYPE("TM")="S"
if '$DATA(SCTM(TMI))
QUIT
+12 ;Look at each position for this team
+13 SET POSI=0
+14 ;
FOR
SET POSI=$ORDER(^SCTM(404.57,"C",TMI,POSI))
if 'POSI
QUIT
Begin DoDot:3
+15 SET POSN=$PIECE($GET(^SCTM(404.57,POSI,0)),U,1)
if POSN']""
QUIT
+16 ;..Check for inconsistencies 4 & 5.
DO CHECK45(TMI,POSI)
+17 if '$DATA(^SCPT(404.43,"APTPA",POSI))
QUIT
+18 ;...Check for inconsistency 1.
DO CHECK1(TMI,POSI)
End DoDot:3
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
PATIENT ;Check for patient inconsistencies.
+1 DO CHECK28
+2 DO CHECK367
+3 QUIT
+4 ;
CHECK1(TMI,POSI) ;Check positions for inconsistency 1.
+1 ;Input:
+2 ; TMI - Team IEN
+3 ; POSI - Team Position IEN
+4 ;
+5 NEW POSN,TMN
+6 ;Current provider. Fld 304 in 404.57.
if +$$GETPRTP^SCAPMCU2(POSI,DT)
QUIT
+7 ;Team inactive
if +$$ACTTM^SCMCTMU(TMI,DT)'=1
QUIT
+8 ;Position inactive
if +$$ACTTP^SCMCTPU(POSI,DT)'=1
QUIT
+9 SET TMN=$$TMNAME(TMI)
+10 SET POSN=$$POSNAME(POSI)
+11 ;.........................#1
SET ^TMP("PCMM POSITION",$JOB,1,TMN,POSN)=""
+12 QUIT
+13 ;
CHECK28 ;Check patients for inconsistencies 2 & 8.
+1 ;
+2 ;Loop thru 404.43 for each patient.
+3 ;Use "ACTDFN" xref. Active entries sorted by patient IEN.
+4 ;
+5 NEW DATA,DFN,DFNNAM,NUM,POSI,POSN,PTI,PTPI,TMI,TMN
+6 ;
+7 SET DFN=0
+8 ;
FOR
SET DFN=$ORDER(^SCPT(404.43,"ACTDFN",DFN))
if 'DFN
QUIT
Begin DoDot:1
+9 SET PTPI=0
+10 ;
FOR
SET PTPI=$ORDER(^SCPT(404.43,"ACTDFN",DFN,PTPI))
if 'PTPI
QUIT
Begin DoDot:2
+11 ;Team Position Assign zero node
SET DATA=$GET(^SCPT(404.43,PTPI,0))
+12 ;.............Inactive
if $PIECE(DATA,U,4)]""
QUIT
+13 ;.....Team Assign IEN
SET PTI=$PIECE(DATA,U,1)
if 'PTI
QUIT
+14 ;...Position
SET POSI=$PIECE(DATA,U,2)
if 'POSI
QUIT
+15 ;.Team Assign zero node
SET DATA=$GET(^SCPT(404.42,PTI,0))
+16 ;.....Team IEN
SET TMI=$PIECE(DATA,U,3)
if 'TMI
QUIT
+17 ;
+18 ;If user selected teams, quit if this one isn't on list.
+19 IF SCTYPE("TM")="S"
if '$DATA(SCTM(TMI))
QUIT
+20 ;
+21 SET POSN=$$POSNAME(POSI)
+22 SET TMN=$$TMNAME(TMI)
+23 ;Patient name
SET DFNNAM=$$PTNAME(DFN)
+24 ;
+25 ;Check for nconsistency 8
Begin DoDot:3
+26 ;...............Tm Pos Assign Inactive....#8
IF $PIECE(DATA,U,9)]""
Begin DoDot:4
+27 SET ^TMP("PCMM PATIENT",$JOB,DFNNAM,DFN,8.1,TMN,POSN)=PTPI
End DoDot:4
+28 ;...Team inactive.............#8
IF +$$ACTTM^SCMCTMU(TMI,DT)'=1
Begin DoDot:4
+29 SET ^TMP("PCMM PATIENT",$JOB,DFNNAM,DFN,8.2,TMN,POSN)=PTPI
End DoDot:4
+30 ;..Position inactive.........#8
IF +$$ACTTP^SCMCTPU(POSI,DT)'=1
Begin DoDot:4
+31 SET ^TMP("PCMM PATIENT",$JOB,DFNNAM,DFN,8.3,TMN,POSN)=PTPI
End DoDot:4
End DoDot:3
+32 ;
+33 ;..Team Assign not PC
if $PIECE(DATA,U,8)'=1
QUIT
+34 ;..Team Assign inactive
if $PIECE(DATA,U,9)]""
QUIT
+35 ;
+36 ;Q:$D(^SCPT(404.43,"APCPOS",DFN,1))
+37 ;sd/528
IF $$GETPRTP^SCAPMCU2(POSI,DT)>0
QUIT
+38 ;..........#2
SET ^TMP("PCMM PATIENT",$JOB,DFNNAM,DFN,2,TMN,POSN)=PTPI
End DoDot:2
End DoDot:1
+39 QUIT
+40 ;
CHECK367 ;Check patients for inconsistencies 3,6,7.
+1 ;
+2 ;Loop thru 404.43 for each patient.
+3 ;Use "ACTPC" xref. Active entries sorted by patient IEN & PC ROLE.
+4 ;
+5 NEW CNT,DATA,DFN,DFNNAM,HLD,POSI,POSN,PTI,PTPI,TMI,TMN
+6 ;
+7 SET DFN=0
+8 ;
FOR
SET DFN=$ORDER(^SCPT(404.43,"ACTPC",DFN))
if 'DFN
QUIT
Begin DoDot:1
+9 ;Initialize for each DFN
SET CNT=0
KILL HLD
+10 SET PTPI=0
+11 ;
FOR
SET PTPI=$ORDER(^SCPT(404.43,"ACTPC",DFN,1,PTPI))
if 'PTPI
QUIT
Begin DoDot:2
+12 ;..Team Position Assign zero node
SET DATA=$GET(^SCPT(404.43,PTPI,0))
+13 ;...............Inactive
if $PIECE(DATA,U,4)]""
QUIT
+14 ;.......Team Assign IEN
SET PTI=$PIECE(DATA,U,1)
if 'PTI
QUIT
+15 ;.....Position
SET POSI=$PIECE(DATA,U,2)
if 'POSI
QUIT
+16 ;...Team Assign zero node
SET DATA=$GET(^SCPT(404.42,PTI,0))
+17 ;.......Team IEN
SET TMI=$PIECE(DATA,U,3)
if 'TMI
QUIT
+18 ;
+19 ;If user selected teams, quit if this one isn't on list.
+20 IF SCTYPE("TM")="S"
if '$DATA(SCTM(TMI))
QUIT
+21 ;
+22 ;...............Team Assign not PC
if $PIECE(DATA,U,8)'=1
QUIT
+23 ;...............Team Assign inactive
if $PIECE(DATA,U,9)]""
QUIT
+24 SET POSN=$$POSNAME(POSI)
+25 SET TMN=$$TMNAME(TMI)
+26 ;Patient name
SET DFNNAM=$$PTNAME(DFN)
+27 ;
+28 DO CHECK67
+29 ;
+30 SET CNT=CNT+1
+31 ;Save 1st occurance. Asingle occurance is not a problem.
+32 IF CNT=1
SET HLD(DFNNAM,DFN,3,TMN,POSN)=""
QUIT
+33 ;
+34 ;If there is a 2nd occurance, move 1st occurance into array.
+35 IF CNT=2
MERGE ^TMP("PCMM PATIENT",$JOB)=HLD
KILL HLD
+36 ;..........#3
SET ^TMP("PCMM PATIENT",$JOB,DFNNAM,DFN,3,TMN,POSN)=PTPI
End DoDot:2
End DoDot:1
+37 QUIT
+38 ;
CHECK45(TMI,POSI) ;Check positions for inconsistencies 4 & 5.
+1 ;Input:
+2 ; TMI - Team IEN
+3 ; POSI - Team Position IEN
+4 ;
+5 NEW AP,DATA,PCP,POSN,PREHI,STAFFAP,STAFFPCP,TMN
+6 ;
+7 SET PREHI=0
+8 ;
FOR
SET PREHI=$ORDER(^SCTM(404.53,"B",POSI,PREHI))
if 'PREHI
QUIT
Begin DoDot:1
+9 SET DATA=$GET(^SCTM(404.53,PREHI,0))
+10 if DATA']""
QUIT
+11 ;.....................Preceptee position
SET AP=$PIECE(DATA,U,1)
+12 ;....................Preceptor position
SET PCP=$PIECE(DATA,U,6)
+13 ;..Preceptee staff person
SET STAFFAP=+$$GETPRTP^SCAPMCU2(AP,DT)
+14 ;Preceptor staff person
SET STAFFPCP=+$$GETPRTP^SCAPMCU2(PCP,DT)
+15 ;
+16 SET TMN=$$TMNAME(TMI)
+17 SET POSN=$$POSNAME(POSI)
+18 ;
IF STAFFAP
IF STAFFAP=STAFFPCP
Begin DoDot:2
+19 ;......................#4
SET ^TMP("PCMM POSITION",$JOB,4,TMN,POSN)=""
End DoDot:2
+20 ;
IF STAFFPCP=""
Begin DoDot:2
+21 ;......................#5
SET ^TMP("PCMM POSITION",$JOB,5,TMN,POSN)=""
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
CHECK67 ;Check patients for inconsistencies 6 & 7.
+1 NEW ERROR,ID,LIST,NUM,POS,RESULT,TYPE,ZDATE
+2 ;
+3 SET ZDATE("BEGIN")=DT
+4 SET ZDATE("END")=DT
+5 SET ZDATE("INCL")=0
+6 ;
+7 SET RESULT=$$PRPTTPC^SCAPMC(PTPI,"ZDATE","LIST","ERROR",1)
+8 ;
+9 SET NUM=0
+10 ;
FOR
SET NUM=$ORDER(LIST(NUM))
if 'NUM
QUIT
Begin DoDot:1
+11 SET TYPE=""
+12 ;
FOR
SET TYPE=$ORDER(LIST(NUM,TYPE))
if TYPE=""
QUIT
Begin DoDot:2
+13 SET ID=""
+14 ;
FOR
SET ID=$ORDER(LIST(NUM,TYPE,ID))
if ID=""
QUIT
Begin DoDot:3
+15 SET POS=$PIECE(LIST(NUM,TYPE,ID),U,3)
if 'POS
QUIT
+16 ;See if field 4, POSSIBLE PRIMARY PRACTITIONER, equals 1.
+17 if $PIECE($GET(^SCTM(404.57,POS,0)),U,4)=1
QUIT
+18 IF TYPE="AP"
Begin DoDot:4
+19 ;........#6
SET ^TMP("PCMM PATIENT",$JOB,DFNNAM,DFN,6,TMN,POSN)=PTPI
End DoDot:4
QUIT
+20 IF TYPE="PCP"
Begin DoDot:4
+21 ;........#7
SET ^TMP("PCMM PATIENT",$JOB,DFNNAM,DFN,7,TMN,POSN)=PTPI
End DoDot:4
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
TMNAME(TMI) ;Return team name
+1 NEW NAME
+2 SET NAME=$PIECE($GET(^SCTM(404.51,TMI,0)),U,1)
+3 if NAME=""
SET NAME="UNKNOWN"
+4 QUIT NAME
+5 ;
POSNAME(POSI) ;Return position name
+1 NEW NAME
+2 SET NAME=$PIECE($GET(^SCTM(404.57,POSI,0)),U,1)
+3 if NAME=""
SET NAME="UNKNOWN"
+4 QUIT NAME
+5 ;
PTNAME(DFN) ;Return patient name
+1 NEW NAME
+2 SET NAME=$PIECE($GET(^DPT(DFN,0)),U,1)
+3 if NAME=""
SET NAME="UNKNOWN"
+4 QUIT NAME
