- 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
- 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
