MCNP2CHK ;HIRMFO/DAD-UNIQUE PROVIDER NAME PRINT ;4/18/96 08:33
;;2.3;Medicine;;09/13/1996
;
K %ZIS,IOP S %ZIS="QM" W ! D ^%ZIS G:POP EXIT
I $D(IO("Q")) D G EXIT
. S ZTRTN="TASK^MCNP2CHK"
. S ZTDESC="Unique New Person Names in Medicine Provider Fields"
. D ^%ZTLOAD S ZTSK=+$G(ZTSK)
. I ZTSK>0 W !!,"Task queued, task number ",ZTSK,"."
. E W !!,"Task not queued."
. Q
TASK ;
D XIT
F MCLINE=1:1 S MCDATA=$P($T(FILEFLD+MCLINE),";",3) Q:MCDATA="" D
. K MCFLD
. S MCFILE=$P(MCDATA,U),MCFLD(0)=$P(MCDATA,U,2)
. S ^TMP("MC",$J,MCFILE)=$$GET1^DID(MCFILE,"","","NAME")
. F MCPIECE=1:1:$L(MCFLD(0),",") D
.. S MCFLD=$P(MCFLD(0),",",MCPIECE) Q:MCFLD'>0
.. K MCDD,MCER
.. D FIELD^DID(MCFILE,MCFLD,"","LABEL;GLOBAL SUBSCRIPT LOCATION","MCDD","MCERR")
.. S MCFLD(MCFLD)=MCDD("GLOBAL SUBSCRIPT LOCATION")
.. S ^TMP("MC",$J,MCFILE,MCFLD)=MCDD("LABEL")
.. Q
. D GETDATA
. Q
PRINT ;
K MCUNDL S MCPAGE=1,MCEXIT=0,$P(MCUNDL,"=",81)=""
S MCTODAY=$$FMTE^XLFDT($$DT^XLFDT)
U IO D HEADER
S MCFILE=0
F S MCFILE=$O(^TMP("MC",$J,MCFILE)) Q:MCFILE'>0!MCEXIT D
. W !!,^TMP("MC",$J,MCFILE)," file (#",MCFILE,")"
. S MCFLD=0
. F S MCFLD=$O(^TMP("MC",$J,MCFILE,MCFLD)) Q:MCFLD'>0!MCEXIT D
.. W !?5,^TMP("MC",$J,MCFILE,MCFLD)," field (#",MCFLD,")"
.. I $O(^TMP("MC",$J,MCFILE,MCFLD,""))="" D Q
... W !?10,"*** NONE ***"
... I $Y>(IOSL-4) D PAUSE,HEADER
... Q
.. S MCPROV=""
.. F S MCPROV=$O(^TMP("MC",$J,MCFILE,MCFLD,MCPROV)) Q:MCPROV=""!MCEXIT D
... S MCDATA=^TMP("MC",$J,MCFILE,MCFLD,MCPROV)
... W !?10,MCPROV,?50,$J($P(MCDATA,U),6),?65,$S($P(MCDATA,U,2):"YES",1:"NO")
... I $Y>(IOSL-4) D PAUSE,HEADER
... Q
.. Q
. Q
EXIT ;
D ^%ZISC
XIT K %ZIS,DIR,DIRUT,DIROUT,DTOUT,MC200,MCD0,MCD1,MCDATA,MCDD,MCER,MCEXIT
K MCFILE,MCFLD,MCLINE,MCNODE,MCPAGE,MCPIECE,MCPROV,MCTODAY,MCUNDL,POP
K X,Y,ZTDESC,ZTRTN,^TMP("MC",$J)
Q
GETDATA ;
S MCD0=0
F S MCD0=$O(^MCAR(MCFILE,MCD0)) Q:MCD0'>0 D
. S MCFLD=0
. F S MCFLD=$O(MCFLD(MCFLD)) Q:MCFLD'>0 D
.. I MCFILE=700,MCFLD=21 D GETMULT Q
.. S MCNODE=$P(MCFLD(MCFLD),";"),MCPIECE=$P(MCFLD(MCFLD),";",2)
.. S MC200=$P($G(^MCAR(MCFILE,MCD0,MCNODE)),U,MCPIECE)
.. D SETTMP(MC200)
.. Q
. Q
Q
GETMULT ;
S MCD1=0
F S MCD1=$O(^MCAR(MCFILE,MCD0,7,MCD1)) Q:MCD1'>0 D
. S MC200=$P($G(^MCAR(MCFILE,MCD0,7,MCD1,0)),U)
. D SETTMP(MC200)
. Q
Q
SETTMP(MC200) ;
I MC200="" Q
S MC200(0)=$P($G(^VA(200,MC200,0)),U) I MC200(0)="" S MC200(0)=MC200
I $D(^TMP("MC",$J,MCFILE,MCFLD,MC200(0)))[0 D
. S MCPROV=$D(^XUSEC("PROVIDER",MC200))
. S ^TMP("MC",$J,MCFILE,MCFLD,MC200(0))=MC200_U_$S(MCPROV[0:0,1:1)
. Q
Q
PAUSE ;
I $E(IOST,1,2)="C-" D
. N DIR S DIR(0)="E" D ^DIR S MCEXIT=$S(Y'>0:1,1:0)
. Q
Q
I MCEXIT Q
W:($E(IOST,1,2)="C-")!(MCPAGE>1) @IOF
W !?15,"Unique New Person Names in Medicine Provider Fields"
W ?68,MCTODAY,!?68,"Page: ",MCPAGE S MCPAGE=MCPAGE+1
W !,"File Name (Number)"
W !?5,"Field Name (Number)"
W !?10,"New Person Name",?50,"IEN",?65,"Provider Key",!,MCUNDL
Q
FILEFLD ;;
;;691^39,43
;;691.1^62,63,64,65
;;691.5^12
;;691.6^4,6,10,12,14
;;691.7^57,58
;;691.8^16,17,19,20
;;691.9^24
;;692^21
;;694^50,51
;;698.3^2
;;699^6,200,201
;;700^10,21,31,34
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCNP2CHK 3268 printed Apr 09, 2024@21:18:57 Page 2
MCNP2CHK ;HIRMFO/DAD-UNIQUE PROVIDER NAME PRINT ;4/18/96 08:33
+1 ;;2.3;Medicine;;09/13/1996
+2 ;
+3 KILL %ZIS,IOP
SET %ZIS="QM"
WRITE !
DO ^%ZIS
if POP
GOTO EXIT
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTRTN="TASK^MCNP2CHK"
+6 SET ZTDESC="Unique New Person Names in Medicine Provider Fields"
+7 DO ^%ZTLOAD
SET ZTSK=+$GET(ZTSK)
+8 IF ZTSK>0
WRITE !!,"Task queued, task number ",ZTSK,"."
+9 IF '$TEST
WRITE !!,"Task not queued."
+10 QUIT
End DoDot:1
GOTO EXIT
TASK ;
+1 DO XIT
+2 FOR MCLINE=1:1
SET MCDATA=$PIECE($TEXT(FILEFLD+MCLINE),";",3)
if MCDATA=""
QUIT
Begin DoDot:1
+3 KILL MCFLD
+4 SET MCFILE=$PIECE(MCDATA,U)
SET MCFLD(0)=$PIECE(MCDATA,U,2)
+5 SET ^TMP("MC",$JOB,MCFILE)=$$GET1^DID(MCFILE,"","","NAME")
+6 FOR MCPIECE=1:1:$LENGTH(MCFLD(0),",")
Begin DoDot:2
+7 SET MCFLD=$PIECE(MCFLD(0),",",MCPIECE)
if MCFLD'>0
QUIT
+8 KILL MCDD,MCER
+9 DO FIELD^DID(MCFILE,MCFLD,"","LABEL;GLOBAL SUBSCRIPT LOCATION","MCDD","MCERR")
+10 SET MCFLD(MCFLD)=MCDD("GLOBAL SUBSCRIPT LOCATION")
+11 SET ^TMP("MC",$JOB,MCFILE,MCFLD)=MCDD("LABEL")
+12 QUIT
End DoDot:2
+13 DO GETDATA
+14 QUIT
End DoDot:1
PRINT ;
+1 KILL MCUNDL
SET MCPAGE=1
SET MCEXIT=0
SET $PIECE(MCUNDL,"=",81)=""
+2 SET MCTODAY=$$FMTE^XLFDT($$DT^XLFDT)
+3 USE IO
DO HEADER
+4 SET MCFILE=0
+5 FOR
SET MCFILE=$ORDER(^TMP("MC",$JOB,MCFILE))
if MCFILE'>0!MCEXIT
QUIT
Begin DoDot:1
+6 WRITE !!,^TMP("MC",$JOB,MCFILE)," file (#",MCFILE,")"
+7 SET MCFLD=0
+8 FOR
SET MCFLD=$ORDER(^TMP("MC",$JOB,MCFILE,MCFLD))
if MCFLD'>0!MCEXIT
QUIT
Begin DoDot:2
+9 WRITE !?5,^TMP("MC",$JOB,MCFILE,MCFLD)," field (#",MCFLD,")"
+10 IF $ORDER(^TMP("MC",$JOB,MCFILE,MCFLD,""))=""
Begin DoDot:3
+11 WRITE !?10,"*** NONE ***"
+12 IF $Y>(IOSL-4)
DO PAUSE
DO HEADER
+13 QUIT
End DoDot:3
QUIT
+14 SET MCPROV=""
+15 FOR
SET MCPROV=$ORDER(^TMP("MC",$JOB,MCFILE,MCFLD,MCPROV))
if MCPROV=""!MCEXIT
QUIT
Begin DoDot:3
+16 SET MCDATA=^TMP("MC",$JOB,MCFILE,MCFLD,MCPROV)
+17 WRITE !?10,MCPROV,?50,$JUSTIFY($PIECE(MCDATA,U),6),?65,$SELECT($PIECE(MCDATA,U,2):"YES",1:"NO")
+18 IF $Y>(IOSL-4)
DO PAUSE
DO HEADER
+19 QUIT
End DoDot:3
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
EXIT ;
+1 DO ^%ZISC
XIT KILL %ZIS,DIR,DIRUT,DIROUT,DTOUT,MC200,MCD0,MCD1,MCDATA,MCDD,MCER,MCEXIT
+1 KILL MCFILE,MCFLD,MCLINE,MCNODE,MCPAGE,MCPIECE,MCPROV,MCTODAY,MCUNDL,POP
+2 KILL X,Y,ZTDESC,ZTRTN,^TMP("MC",$JOB)
+3 QUIT
GETDATA ;
+1 SET MCD0=0
+2 FOR
SET MCD0=$ORDER(^MCAR(MCFILE,MCD0))
if MCD0'>0
QUIT
Begin DoDot:1
+3 SET MCFLD=0
+4 FOR
SET MCFLD=$ORDER(MCFLD(MCFLD))
if MCFLD'>0
QUIT
Begin DoDot:2
+5 IF MCFILE=700
IF MCFLD=21
DO GETMULT
QUIT
+6 SET MCNODE=$PIECE(MCFLD(MCFLD),";")
SET MCPIECE=$PIECE(MCFLD(MCFLD),";",2)
+7 SET MC200=$PIECE($GET(^MCAR(MCFILE,MCD0,MCNODE)),U,MCPIECE)
+8 DO SETTMP(MC200)
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT
GETMULT ;
+1 SET MCD1=0
+2 FOR
SET MCD1=$ORDER(^MCAR(MCFILE,MCD0,7,MCD1))
if MCD1'>0
QUIT
Begin DoDot:1
+3 SET MC200=$PIECE($GET(^MCAR(MCFILE,MCD0,7,MCD1,0)),U)
+4 DO SETTMP(MC200)
+5 QUIT
End DoDot:1
+6 QUIT
SETTMP(MC200) ;
+1 IF MC200=""
QUIT
+2 SET MC200(0)=$PIECE($GET(^VA(200,MC200,0)),U)
IF MC200(0)=""
SET MC200(0)=MC200
+3 IF $DATA(^TMP("MC",$JOB,MCFILE,MCFLD,MC200(0)))[0
Begin DoDot:1
+4 SET MCPROV=$DATA(^XUSEC("PROVIDER",MC200))
+5 SET ^TMP("MC",$JOB,MCFILE,MCFLD,MC200(0))=MC200_U_$SELECT(MCPROV[0:0,1:1)
+6 QUIT
End DoDot:1
+7 QUIT
PAUSE ;
+1 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+2 NEW DIR
SET DIR(0)="E"
DO ^DIR
SET MCEXIT=$SELECT(Y'>0:1,1:0)
+3 QUIT
End DoDot:1
+4 QUIT
+1 IF MCEXIT
QUIT
+2 if ($EXTRACT(IOST,1,2)="C-")!(MCPAGE>1)
WRITE @IOF
+3 WRITE !?15,"Unique New Person Names in Medicine Provider Fields"
+4 WRITE ?68,MCTODAY,!?68,"Page: ",MCPAGE
SET MCPAGE=MCPAGE+1
+5 WRITE !,"File Name (Number)"
+6 WRITE !?5,"Field Name (Number)"
+7 WRITE !?10,"New Person Name",?50,"IEN",?65,"Provider Key",!,MCUNDL
+8 QUIT
FILEFLD ;;
+1 ;;691^39,43
+2 ;;691.1^62,63,64,65
+3 ;;691.5^12
+4 ;;691.6^4,6,10,12,14
+5 ;;691.7^57,58
+6 ;;691.8^16,17,19,20
+7 ;;691.9^24
+8 ;;692^21
+9 ;;694^50,51
+10 ;;698.3^2
+11 ;;699^6,200,201
+12 ;;700^10,21,31,34
