SCRPV1B ; bp/djb - PCMM Inconsistency Rpt - Print ; 9/13/99 3:23pm
;;5.3;Scheduling;**177,231**;AUG 13, 1993
;
EN ;
NEW PAGE,QUIT
S QUIT=0
D HD
D POSITION Q:QUIT
D PATIENT
Q
;
POSITION ;Print position inconsistencies.
NEW NUM,POS,TM,TXT
;
W !!,"POSITION INCONSISTENCIES"
W !,"------------------------",!
I '$D(^TMP("PCMM POSITION",$J)) W !?3,"No inconsistencies found." Q
I SCMODE="B" D BRIEFPOS^SCRPV1B1 Q ;Report type = Brief
W !?3,"INCONSISTENCY"
W !?6,"TEAM",?38,"POSITION",!
;
;Process the POSITION array
S NUM=0
F S NUM=$O(^TMP("PCMM POSITION",$J,NUM)) Q:'NUM!QUIT D ;
. S TXT=$T(TXT+NUM)
. S TXT=$P(TXT,";",4)
. I $Y>(IOSL-6) D PAUSE Q:QUIT
. W !?3,TXT
. S TM=""
. F S TM=$O(^TMP("PCMM POSITION",$J,NUM,TM)) Q:TM=""!QUIT D
.. S POS=""
.. F S POS=$O(^TMP("PCMM POSITION",$J,NUM,TM,POS)) Q:POS=""!QUIT D
... I $Y>(IOSL-6) D PAUSE Q:QUIT
... W !,?6,TM,?38,POS
Q
;
PATIENT ;Print patient inconsistencies
;
I $Y>(IOSL-7) D PAUSE Q:QUIT
W !!,"PATIENT INCONSISTENCIES"
W !,"-----------------------",!
I '$D(^TMP("PCMM PATIENT",$J)) D Q
. W !?3,"No inconsistencies found.",!
I $Y>(IOSL-6) D PAUSE Q:QUIT
I SCMODE="B" D BRIEFPT^SCRPV1B1 Q ;Report type = Brief
I SCMODE="DP" D PATIENT1 Q
I SCMODE="DT" D PATIENT2 Q
Q
;
PATIENT1 ;Patient printout sorted by patient name.
NEW DFN,DFNNAM,NUM,POS,SSN,TM,TXT,VAR
;
W !?3,"PATIENT",?41,"SSN"
W !?6,"INCONSISTENCY"
W !?9,"TEAM",?41,"POSITION",!
;
;Process the PATIENT array
S DFNNAM=""
F S DFNNAM=$O(^TMP("PCMM PATIENT",$J,DFNNAM)) Q:DFNNAM=""!QUIT D ;
. S DFN=0
. F S DFN=$O(^TMP("PCMM PATIENT",$J,DFNNAM,DFN)) Q:'DFN!QUIT D ;
.. I $Y>(IOSL-6) D PAUSE Q:QUIT
.. S SSN=$P($G(^DPT(DFN,0)),U,9)
.. W !?3,DFNNAM,?41,SSN
.. S NUM=0
.. F S NUM=$O(^TMP("PCMM PATIENT",$J,DFNNAM,DFN,NUM)) Q:'NUM!QUIT D
... S VAR=0
... ;If number is 8.1, 8.2 or 8.3, substitute in 3 choices below.
... I NUM?1"8.".E S VAR=$P(NUM,".",2)
... S TXT=$T(TXT+(NUM\1))
... S TXT=$P(TXT,";",4)
... I VAR D ;
.... S VAR=$S(VAR=1:"Team Assignment",VAR=2:"Team",1:"Position")
.... S TXT=$P(TXT,"[]",1)_VAR_$P(TXT,"[]",2)
... I $Y>(IOSL-6) D PAUSE Q:QUIT
... ;W !?6,(NUM\1),". ",TXT
... W !?6,TXT
... S TM=""
... F S TM=$O(^TMP("PCMM PATIENT",$J,DFNNAM,DFN,NUM,TM)) Q:TM=""!QUIT D
.... S POS=""
.... F S POS=$O(^TMP("PCMM PATIENT",$J,DFNNAM,DFN,NUM,TM,POS)) Q:POS=""!QUIT D
..... I $Y>(IOSL-6) D PAUSE Q:QUIT
..... W !?9,TM,?41,POS
..... ;
..... ;Print 404.43 IEN if SCIEN is set to 1 before calling ^SCRPV1.
..... I $G(SCIEN) D ;
...... I $G(^TMP("PCMM PATIENT",$J,DFNNAM,DFN,NUM,TM,POS)) W ?72,^(POS)
Q
;
PATIENT2 ;Patient printout sorted by inconsistency number and then team name.
NEW DFN,DFNNAM,NUM,POS,SSN,TM,TXT,VAR
;
W !,"INCONSISTENCY"
W !?3,"TEAM"
W !?6,"PATIENT",?38,"SSN",?50,"POSITION",!
;
KILL ^TMP("PCMM PATIENT1",$J)
;
;Reorder PATIENT array
S DFNNAM=""
F S DFNNAM=$O(^TMP("PCMM PATIENT",$J,DFNNAM)) Q:DFNNAM="" D ;
. S DFN=0
. F S DFN=$O(^TMP("PCMM PATIENT",$J,DFNNAM,DFN)) Q:'DFN D ;
.. S NUM=0
.. F S NUM=$O(^TMP("PCMM PATIENT",$J,DFNNAM,DFN,NUM)) Q:'NUM D ;
... S TM=""
... F S TM=$O(^TMP("PCMM PATIENT",$J,DFNNAM,DFN,NUM,TM)) Q:TM="" D
.... S POS=""
.... F S POS=$O(^TMP("PCMM PATIENT",$J,DFNNAM,DFN,NUM,TM,POS)) Q:POS="" D
..... S ^TMP("PCMM PATIENT1",$J,NUM,TM,DFNNAM,DFN,POS)=""
;
;Process new array
S NUM=0
F S NUM=$O(^TMP("PCMM PATIENT1",$J,NUM)) Q:'NUM!QUIT D ;
. S VAR=0
. ;If number is 8.1, 8.2 or 8.3, substitute in 3 choices below.
. I NUM?1"8.".E S VAR=$P(NUM,".",2)
. S TXT=$T(TXT+(NUM\1))
. S TXT=$P(TXT,";",4)
. I VAR D ;
.. S VAR=$S(VAR=1:"Team Assignment",VAR=2:"Team",1:"Position")
.. S TXT=$P(TXT,"[]",1)_VAR_$P(TXT,"[]",2)
. ;
. I $Y>(IOSL-6) D PAUSE Q:QUIT
. W !,TXT
. ;
. S TM=""
. F S TM=$O(^TMP("PCMM PATIENT1",$J,NUM,TM)) Q:TM=""!QUIT D ;
.. I $Y>(IOSL-6) D PAUSE Q:QUIT
.. W !?3,TM
.. S DFNNAM=""
.. F S DFNNAM=$O(^TMP("PCMM PATIENT1",$J,NUM,TM,DFNNAM)) Q:DFNNAM=""!QUIT D ;
... S DFN=0
... F S DFN=$O(^TMP("PCMM PATIENT1",$J,NUM,TM,DFNNAM,DFN)) Q:'DFN!QUIT D
.... S POS=0
.... F S POS=$O(^TMP("PCMM PATIENT1",$J,NUM,TM,DFNNAM,DFN,POS)) Q:'POS!QUIT D ;
..... S SSN=$P($G(^DPT(DFN,0)),U,9)
..... I $Y>(IOSL-6) D PAUSE Q:QUIT
..... W !?6,DFNNAM,?38,SSN,?50,POS
;
KILL ^TMP("PCMM PATIENT1",$J)
Q
;
PAUSE ;Pause the display
NEW ANS,COL,PGTXT
S PAGE=PAGE+1
I $G(ION)="HFS" Q
S PGTXT="Page: "_PAGE
S COL=(IOM-$L(PGTXT)-2)
I $E(IOST,1,2)="P-" W @IOF,!?COL,PGTXT Q
W !,"<RET> to continue, ^ to quit: "
R ANS:DTIME S:'$T ANS="^" I ANS["^" S QUIT=1 Q
W @IOF,!?COL,PGTXT
Q
;
HD ;Heading
NEW HD,LINE,NOW,TM,TMN
;
S PAGE=1
S HD="PCMM INCONSISTENCY REPORT"
;Adjust heading if going to the P-MESSAGE device
I IOST["P-",IOST["MESSAGE" D Q
. W !?(78-$L(HD)\2),HD
;
I $E(IOST,1,2)="P-" W !!
E W @IOF
S $P(LINE,"=",IOM)=""
W !?(IOM-$L(HD)\2),HD
S NOW=$$NOW^XLFDT()
I $P(NOW,".",2) S NOW=$P(NOW,".",1)_"."_$E($P(NOW,".",2),1,4)
S HD=$$FMTE^XLFDT(NOW)
W !?(IOM-$L(HD)\2),HD
W !,LINE
I SCTYPE("TM")="I" D ;
. W !,"See PCMM User Guide for detailed instructions."
E D ;
. W !,"Teams: "
. I SCTYPE("TM")="A" W "All teams"
. E D ;
.. S TM=0
.. F S TM=$O(SCTM(TM)) Q:'TM D ;
... S TMN=$P($G(^SCTM(404.51,TM,0)),U,1)
... S:TMN']"" TMN="UNKNOWN"
... I ($L(TMN)+$X+2)>IOM W !?7
... W TMN
... I $O(SCTM(TM)) W ", "
W !,LINE
Q
;
TXT ;Inconsistencies
;;1;Position has no staff assigned
;;2;Patient has no PCP assigned
;;3;Patient has multiple PCPs assigned
;;4;AP & PCP are the same provider
;;5;AP is without a Preceptor
;;6;AP position is not designated for PC
;;7;PCP position is not designated for PC
;;8;Position assignment with inactive []
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPV1B 5916 printed Sep 23, 2025@20:19:34 Page 2
SCRPV1B ; bp/djb - PCMM Inconsistency Rpt - Print ; 9/13/99 3:23pm
+1 ;;5.3;Scheduling;**177,231**;AUG 13, 1993
+2 ;
EN ;
+1 NEW PAGE,QUIT
+2 SET QUIT=0
+3 DO HD
+4 DO POSITION
if QUIT
QUIT
+5 DO PATIENT
+6 QUIT
+7 ;
POSITION ;Print position inconsistencies.
+1 NEW NUM,POS,TM,TXT
+2 ;
+3 WRITE !!,"POSITION INCONSISTENCIES"
+4 WRITE !,"------------------------",!
+5 IF '$DATA(^TMP("PCMM POSITION",$JOB))
WRITE !?3,"No inconsistencies found."
QUIT
+6 ;Report type = Brief
IF SCMODE="B"
DO BRIEFPOS^SCRPV1B1
QUIT
+7 WRITE !?3,"INCONSISTENCY"
+8 WRITE !?6,"TEAM",?38,"POSITION",!
+9 ;
+10 ;Process the POSITION array
+11 SET NUM=0
+12 ;
FOR
SET NUM=$ORDER(^TMP("PCMM POSITION",$JOB,NUM))
if 'NUM!QUIT
QUIT
Begin DoDot:1
+13 SET TXT=$TEXT(TXT+NUM)
+14 SET TXT=$PIECE(TXT,";",4)
+15 IF $Y>(IOSL-6)
DO PAUSE
if QUIT
QUIT
+16 WRITE !?3,TXT
+17 SET TM=""
+18 FOR
SET TM=$ORDER(^TMP("PCMM POSITION",$JOB,NUM,TM))
if TM=""!QUIT
QUIT
Begin DoDot:2
+19 SET POS=""
+20 FOR
SET POS=$ORDER(^TMP("PCMM POSITION",$JOB,NUM,TM,POS))
if POS=""!QUIT
QUIT
Begin DoDot:3
+21 IF $Y>(IOSL-6)
DO PAUSE
if QUIT
QUIT
+22 WRITE !,?6,TM,?38,POS
End DoDot:3
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
PATIENT ;Print patient inconsistencies
+1 ;
+2 IF $Y>(IOSL-7)
DO PAUSE
if QUIT
QUIT
+3 WRITE !!,"PATIENT INCONSISTENCIES"
+4 WRITE !,"-----------------------",!
+5 IF '$DATA(^TMP("PCMM PATIENT",$JOB))
Begin DoDot:1
+6 WRITE !?3,"No inconsistencies found.",!
End DoDot:1
QUIT
+7 IF $Y>(IOSL-6)
DO PAUSE
if QUIT
QUIT
+8 ;Report type = Brief
IF SCMODE="B"
DO BRIEFPT^SCRPV1B1
QUIT
+9 IF SCMODE="DP"
DO PATIENT1
QUIT
+10 IF SCMODE="DT"
DO PATIENT2
QUIT
+11 QUIT
+12 ;
PATIENT1 ;Patient printout sorted by patient name.
+1 NEW DFN,DFNNAM,NUM,POS,SSN,TM,TXT,VAR
+2 ;
+3 WRITE !?3,"PATIENT",?41,"SSN"
+4 WRITE !?6,"INCONSISTENCY"
+5 WRITE !?9,"TEAM",?41,"POSITION",!
+6 ;
+7 ;Process the PATIENT array
+8 SET DFNNAM=""
+9 ;
FOR
SET DFNNAM=$ORDER(^TMP("PCMM PATIENT",$JOB,DFNNAM))
if DFNNAM=""!QUIT
QUIT
Begin DoDot:1
+10 SET DFN=0
+11 ;
FOR
SET DFN=$ORDER(^TMP("PCMM PATIENT",$JOB,DFNNAM,DFN))
if 'DFN!QUIT
QUIT
Begin DoDot:2
+12 IF $Y>(IOSL-6)
DO PAUSE
if QUIT
QUIT
+13 SET SSN=$PIECE($GET(^DPT(DFN,0)),U,9)
+14 WRITE !?3,DFNNAM,?41,SSN
+15 SET NUM=0
+16 FOR
SET NUM=$ORDER(^TMP("PCMM PATIENT",$JOB,DFNNAM,DFN,NUM))
if 'NUM!QUIT
QUIT
Begin DoDot:3
+17 SET VAR=0
+18 ;If number is 8.1, 8.2 or 8.3, substitute in 3 choices below.
+19 IF NUM?1"8.".E
SET VAR=$PIECE(NUM,".",2)
+20 SET TXT=$TEXT(TXT+(NUM\1))
+21 SET TXT=$PIECE(TXT,";",4)
+22 ;
IF VAR
Begin DoDot:4
+23 SET VAR=$SELECT(VAR=1:"Team Assignment",VAR=2:"Team",1:"Position")
+24 SET TXT=$PIECE(TXT,"[]",1)_VAR_$PIECE(TXT,"[]",2)
End DoDot:4
+25 IF $Y>(IOSL-6)
DO PAUSE
if QUIT
QUIT
+26 ;W !?6,(NUM\1),". ",TXT
+27 WRITE !?6,TXT
+28 SET TM=""
+29 FOR
SET TM=$ORDER(^TMP("PCMM PATIENT",$JOB,DFNNAM,DFN,NUM,TM))
if TM=""!QUIT
QUIT
Begin DoDot:4
+30 SET POS=""
+31 FOR
SET POS=$ORDER(^TMP("PCMM PATIENT",$JOB,DFNNAM,DFN,NUM,TM,POS))
if POS=""!QUIT
QUIT
Begin DoDot:5
+32 IF $Y>(IOSL-6)
DO PAUSE
if QUIT
QUIT
+33 WRITE !?9,TM,?41,POS
+34 ;
+35 ;Print 404.43 IEN if SCIEN is set to 1 before calling ^SCRPV1.
+36 ;
IF $GET(SCIEN)
Begin DoDot:6
+37 IF $GET(^TMP("PCMM PATIENT",$JOB,DFNNAM,DFN,NUM,TM,POS))
WRITE ?72,^(POS)
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+38 QUIT
+39 ;
PATIENT2 ;Patient printout sorted by inconsistency number and then team name.
+1 NEW DFN,DFNNAM,NUM,POS,SSN,TM,TXT,VAR
+2 ;
+3 WRITE !,"INCONSISTENCY"
+4 WRITE !?3,"TEAM"
+5 WRITE !?6,"PATIENT",?38,"SSN",?50,"POSITION",!
+6 ;
+7 KILL ^TMP("PCMM PATIENT1",$JOB)
+8 ;
+9 ;Reorder PATIENT array
+10 SET DFNNAM=""
+11 ;
FOR
SET DFNNAM=$ORDER(^TMP("PCMM PATIENT",$JOB,DFNNAM))
if DFNNAM=""
QUIT
Begin DoDot:1
+12 SET DFN=0
+13 ;
FOR
SET DFN=$ORDER(^TMP("PCMM PATIENT",$JOB,DFNNAM,DFN))
if 'DFN
QUIT
Begin DoDot:2
+14 SET NUM=0
+15 ;
FOR
SET NUM=$ORDER(^TMP("PCMM PATIENT",$JOB,DFNNAM,DFN,NUM))
if 'NUM
QUIT
Begin DoDot:3
+16 SET TM=""
+17 FOR
SET TM=$ORDER(^TMP("PCMM PATIENT",$JOB,DFNNAM,DFN,NUM,TM))
if TM=""
QUIT
Begin DoDot:4
+18 SET POS=""
+19 FOR
SET POS=$ORDER(^TMP("PCMM PATIENT",$JOB,DFNNAM,DFN,NUM,TM,POS))
if POS=""
QUIT
Begin DoDot:5
+20 SET ^TMP("PCMM PATIENT1",$JOB,NUM,TM,DFNNAM,DFN,POS)=""
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+21 ;
+22 ;Process new array
+23 SET NUM=0
+24 ;
FOR
SET NUM=$ORDER(^TMP("PCMM PATIENT1",$JOB,NUM))
if 'NUM!QUIT
QUIT
Begin DoDot:1
+25 SET VAR=0
+26 ;If number is 8.1, 8.2 or 8.3, substitute in 3 choices below.
+27 IF NUM?1"8.".E
SET VAR=$PIECE(NUM,".",2)
+28 SET TXT=$TEXT(TXT+(NUM\1))
+29 SET TXT=$PIECE(TXT,";",4)
+30 ;
IF VAR
Begin DoDot:2
+31 SET VAR=$SELECT(VAR=1:"Team Assignment",VAR=2:"Team",1:"Position")
+32 SET TXT=$PIECE(TXT,"[]",1)_VAR_$PIECE(TXT,"[]",2)
End DoDot:2
+33 ;
+34 IF $Y>(IOSL-6)
DO PAUSE
if QUIT
QUIT
+35 WRITE !,TXT
+36 ;
+37 SET TM=""
+38 ;
FOR
SET TM=$ORDER(^TMP("PCMM PATIENT1",$JOB,NUM,TM))
if TM=""!QUIT
QUIT
Begin DoDot:2
+39 IF $Y>(IOSL-6)
DO PAUSE
if QUIT
QUIT
+40 WRITE !?3,TM
+41 SET DFNNAM=""
+42 ;
FOR
SET DFNNAM=$ORDER(^TMP("PCMM PATIENT1",$JOB,NUM,TM,DFNNAM))
if DFNNAM=""!QUIT
QUIT
Begin DoDot:3
+43 SET DFN=0
+44 FOR
SET DFN=$ORDER(^TMP("PCMM PATIENT1",$JOB,NUM,TM,DFNNAM,DFN))
if 'DFN!QUIT
QUIT
Begin DoDot:4
+45 SET POS=0
+46 ;
FOR
SET POS=$ORDER(^TMP("PCMM PATIENT1",$JOB,NUM,TM,DFNNAM,DFN,POS))
if 'POS!QUIT
QUIT
Begin DoDot:5
+47 SET SSN=$PIECE($GET(^DPT(DFN,0)),U,9)
+48 IF $Y>(IOSL-6)
DO PAUSE
if QUIT
QUIT
+49 WRITE !?6,DFNNAM,?38,SSN,?50,POS
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+50 ;
+51 KILL ^TMP("PCMM PATIENT1",$JOB)
+52 QUIT
+53 ;
PAUSE ;Pause the display
+1 NEW ANS,COL,PGTXT
+2 SET PAGE=PAGE+1
+3 IF $GET(ION)="HFS"
QUIT
+4 SET PGTXT="Page: "_PAGE
+5 SET COL=(IOM-$LENGTH(PGTXT)-2)
+6 IF $EXTRACT(IOST,1,2)="P-"
WRITE @IOF,!?COL,PGTXT
QUIT
+7 WRITE !,"<RET> to continue, ^ to quit: "
+8 READ ANS:DTIME
if '$TEST
SET ANS="^"
IF ANS["^"
SET QUIT=1
QUIT
+9 WRITE @IOF,!?COL,PGTXT
+10 QUIT
+11 ;
HD ;Heading
+1 NEW HD,LINE,NOW,TM,TMN
+2 ;
+3 SET PAGE=1
+4 SET HD="PCMM INCONSISTENCY REPORT"
+5 ;Adjust heading if going to the P-MESSAGE device
+6 IF IOST["P-"
IF IOST["MESSAGE"
Begin DoDot:1
+7 WRITE !?(78-$LENGTH(HD)\2),HD
End DoDot:1
QUIT
+8 ;
+9 IF $EXTRACT(IOST,1,2)="P-"
WRITE !!
+10 IF '$TEST
WRITE @IOF
+11 SET $PIECE(LINE,"=",IOM)=""
+12 WRITE !?(IOM-$LENGTH(HD)\2),HD
+13 SET NOW=$$NOW^XLFDT()
+14 IF $PIECE(NOW,".",2)
SET NOW=$PIECE(NOW,".",1)_"."_$EXTRACT($PIECE(NOW,".",2),1,4)
+15 SET HD=$$FMTE^XLFDT(NOW)
+16 WRITE !?(IOM-$LENGTH(HD)\2),HD
+17 WRITE !,LINE
+18 ;
IF SCTYPE("TM")="I"
Begin DoDot:1
+19 WRITE !,"See PCMM User Guide for detailed instructions."
End DoDot:1
+20 ;
IF '$TEST
Begin DoDot:1
+21 WRITE !,"Teams: "
+22 IF SCTYPE("TM")="A"
WRITE "All teams"
+23 ;
IF '$TEST
Begin DoDot:2
+24 SET TM=0
+25 ;
FOR
SET TM=$ORDER(SCTM(TM))
if 'TM
QUIT
Begin DoDot:3
+26 SET TMN=$PIECE($GET(^SCTM(404.51,TM,0)),U,1)
+27 if TMN']""
SET TMN="UNKNOWN"
+28 IF ($LENGTH(TMN)+$X+2)>IOM
WRITE !?7
+29 WRITE TMN
+30 IF $ORDER(SCTM(TM))
WRITE ", "
End DoDot:3
End DoDot:2
End DoDot:1
+31 WRITE !,LINE
+32 QUIT
+33 ;
TXT ;Inconsistencies
+1 ;;1;Position has no staff assigned
+2 ;;2;Patient has no PCP assigned
+3 ;;3;Patient has multiple PCPs assigned
+4 ;;4;AP & PCP are the same provider
+5 ;;5;AP is without a Preceptor
+6 ;;6;AP position is not designated for PC
+7 ;;7;PCP position is not designated for PC
+8 ;;8;Position assignment with inactive []
+9 QUIT
