LRARNPX.m

LRARNPX ; IHS/DIR/AAB - NEW PERSON CONVERSION FOR ^LAR("Z" ;  [ 07/22/2002  1:07 PM ]

 ;;5.2;LR;**1002,1013**;JUL 15, 2002

 ;;5.2;LAB SERVICE;**59,150**;Sep 27, 1994

EN ;

 I ('$G(DUZ)!('$D(DUZ(0)))) W !!?10,$C(7),"Please do ^XUP ",!! Q

 N LRZD0,LRAC,LRDSC,LRDT,LRIO,LRJOB,X,ZTSK

 D DEVICE^LRARNPX0 I LRIO="POP" Q

 D QUE

 D WRAPUP

 Q

DQ ;

 Q:'$D(ZTQUEUED)

 N LRZD0,LRFILE,LRLST,LRTSK

 S LRFILE="LAR-63.9999",LRZD0=0,(LRST,LRJOB)=1,LRTSK=$G(ZTSK)

 ; ^XTMP("LR52","LAR-63.9999",LRJOB,0) is the last record converted successfully

 K ^XTMP("LR52",LRFILE),^XTMP("LR52TIME",LRFILE)

 S ^XTMP("LR52",LRFILE,LRJOB,0)=0

 S ^XTMP("LR52TIME",LRFILE,LRJOB)=$$NOW^LRAFUNC1

 F  S LRLST=LRZD0,LRZD0=+$O(^LAR("Z",LRZD0)) Q:LRZD0<1  D

 . D CH,MI

 . S ^XTMP("LR52",LRFILE,LRJOB,0)=LRZD0

 S $P(^XTMP("LR52TIME",LRFILE,LRJOB),U,2)=$$NOW^LRAFUNC1

 D OUT^LRARNPX1

 D WRAPUP

 Q

QUE ;

 ; Task off JOB to convert file 63.9999

 S ZTIO=""

 S (LRDSC,ZTDESC)="LAB Conversion File 63.9999 (ARCHIVED LR DATA)"

 S ZTSAVE("LRIO")=LRIO,ZTRTN="DQ^LRARNPX" D ^%ZTLOAD,DISP

 Q

CH ; change pointers in CHEM HEM, TOX, RIA, SER, etc. subfile 63.999904

 ; sub("CH") Change REQUESTING PERSON field .1 pointer

 ; ^LAR("Z",LRDFN,"CH",LRIDT,"NPC")=1 Indicates this record has been

 ;converted to File 200. This node is used when restoring arch records.

 ; "NPC")=2 indicates record processed but no provider number

 N LRSB,LRZD1,LRPRV

 S LRSB(0)="CH"

 S LRZD1=0 F  S LRZD1=$O(^LAR("Z",LRZD0,"CH",LRZD1)) Q:'LRZD1  D

 . Q:$D(^LAR("Z",LRZD0,"CH",LRZD1,"NPC"))#2

 . S LRD0=$G(^LAR("Z",LRZD0,"CH",LRZD1,0)),LRPRV=$P(LRD0,U,10)

 . I 'LRPRV S ^LAR("Z",LRZD0,"CH",LRZD1,"NPC")=2 Q

 . I LRPRV D

 .. S $P(LRD0,U,10)=$$PROV^LRARNPX1("63.999904,.1",LRPRV,.LRSB)

 .. S ^LAR("Z",LRZD0,"CH",LRZD1,0)=LRD0,^("NPC")=1

 Q

MI ; change pointers in MICROBIOLOGY subfile 63.999905

 ; sub("MI") Change PHYSICIAN field .07 pointer

 ; ^LAR("Z",LRDFN,"MI",LRIDT,"NPC")=1 Indicates this record has been

 ; converted to File 200. This node is used when restoring arc records.

 ; "NPC")=2 indicates record processed but no provider number

 N LRSB,LRZD1,LRPRV

 S LRSB(0)="MI"

 S LRZD1=0 F  S LRZD1=$O(^LAR("Z",LRZD0,"MI",LRZD1)) Q:'LRZD1  D

 . Q:$D(^LAR("Z",LRZD0,"MI",LRZD1,"NPC"))#2

 . S LRPRV=$P($G(^LAR("Z",LRZD0,"MI",LRZD1,0)),U,7)

 . I 'LRPRV S ^LAR("Z",LRZD0,"MI",LRZD1,"NPC")=2 Q

 . I LRPRV S $P(^LAR("Z",LRZD0,"MI",LRZD1,0),U,7)=$$PROV^LRARNPX1("63.999905,.07",LRPRV,.LRSB),^("NPC")=1

 Q

DISP ; to display to the user the tasked job descriptions and TASK

 ; numbers for the different conversion routines

 W $C(7),!!!,$C(7),"Task # "_ZTSK,!,"with the description of '"_LRDSC_"'"

 W !,"has been scheduled to run "

 W $$DDDATE^LRAFUNC1($$CDHTFM^LRAFUNC1(ZTSK("D")),2)_".",$C(7),!

 K ZTSK,ZTDTH

 Q

WRAPUP ;

 K ZTSK,ZTDESC,ZTRTN,ZTSAVE,ZTIO,ZTDTH,%ZIS,POP,X,Y,%,%X,%Y,DIC,I

 K LRTSK,LRD0,LRZD0,LRD1,LRZD1,LRLST,LRFILE,LRIO,LRJOB,LRDSC,LRAC,LRPRV

 K LRSB,LRST,LRDT,LRSORT

 Q

LRARNPX   ; IHS/DIR/AAB - NEW PERSON CONVERSION FOR ^LAR("Z" ;  [ 07/22/2002  1:07 PM ]

 +1       ;;5.2;LR;**1002,1013**;JUL 15, 2002

 +2       ;;5.2;LAB SERVICE;**59,150**;Sep 27, 1994

EN        ;

 +1        IF ('$GET(DUZ)!('$DATA(DUZ(0))))

               WRITE !!?10,$CHAR(7),"Please do ^XUP ",!!

               QUIT 

 +2        NEW LRZD0,LRAC,LRDSC,LRDT,LRIO,LRJOB,X,ZTSK

 +3        DO DEVICE^LRARNPX0

           IF LRIO="POP"

               QUIT 

 +4        DO QUE

 +5        DO WRAPUP

 +6        QUIT 

DQ        ;

 +1        IF '$DATA(ZTQUEUED)

               QUIT 

 +2        NEW LRZD0,LRFILE,LRLST,LRTSK

 +3        SET LRFILE="LAR-63.9999"

           SET LRZD0=0

           SET (LRST,LRJOB)=1

           SET LRTSK=$GET(ZTSK)

 +4       ; ^XTMP("LR52","LAR-63.9999",LRJOB,0) is the last record converted successfully

 +5        KILL ^XTMP("LR52",LRFILE),^XTMP("LR52TIME",LRFILE)

 +6        SET ^XTMP("LR52",LRFILE,LRJOB,0)=0

 +7        SET ^XTMP("LR52TIME",LRFILE,LRJOB)=$$NOW^LRAFUNC1

 +8        FOR 

               SET LRLST=LRZD0

               SET LRZD0=+$ORDER(^LAR("Z",LRZD0))

               IF LRZD0<1

                   QUIT 

               Begin DoDot:1

 +9                DO CH

                   DO MI

 +10               SET ^XTMP("LR52",LRFILE,LRJOB,0)=LRZD0

               End DoDot:1

 +11       SET $PIECE(^XTMP("LR52TIME",LRFILE,LRJOB),U,2)=$$NOW^LRAFUNC1

 +12       DO OUT^LRARNPX1

 +13       DO WRAPUP

 +14       QUIT 

QUE       ;

 +1       ; Task off JOB to convert file 63.9999

 +2        SET ZTIO=""

 +3        SET (LRDSC,ZTDESC)="LAB Conversion File 63.9999 (ARCHIVED LR DATA)"

 +4        SET ZTSAVE("LRIO")=LRIO

           SET ZTRTN="DQ^LRARNPX"

           DO ^%ZTLOAD

           DO DISP

 +5        QUIT 

CH        ; change pointers in CHEM HEM, TOX, RIA, SER, etc. subfile 63.999904

 +1       ; sub("CH") Change REQUESTING PERSON field .1 pointer

 +2       ; ^LAR("Z",LRDFN,"CH",LRIDT,"NPC")=1 Indicates this record has been

 +3       ;converted to File 200. This node is used when restoring arch records.

 +4       ; "NPC")=2 indicates record processed but no provider number

 +5        NEW LRSB,LRZD1,LRPRV

 +6        SET LRSB(0)="CH"

 +7        SET LRZD1=0

           FOR 

               SET LRZD1=$ORDER(^LAR("Z",LRZD0,"CH",LRZD1))

               IF 'LRZD1

                   QUIT 

               Begin DoDot:1

 +8                IF $DATA(^LAR("Z",LRZD0,"CH",LRZD1,"NPC"))#2

                       QUIT 

 +9                SET LRD0=$GET(^LAR("Z",LRZD0,"CH",LRZD1,0))

                   SET LRPRV=$PIECE(LRD0,U,10)

 +10               IF 'LRPRV

                       SET ^LAR("Z",LRZD0,"CH",LRZD1,"NPC")=2

                       QUIT 

 +11               IF LRPRV

                       Begin DoDot:2

 +12                       SET $PIECE(LRD0,U,10)=$$PROV^LRARNPX1("63.999904,.1",LRPRV,.LRSB)

 +13                       SET ^LAR("Z",LRZD0,"CH",LRZD1,0)=LRD0

                           SET ^("NPC")=1

                       End DoDot:2

               End DoDot:1

 +14       QUIT 

MI        ; change pointers in MICROBIOLOGY subfile 63.999905

 +1       ; sub("MI") Change PHYSICIAN field .07 pointer

 +2       ; ^LAR("Z",LRDFN,"MI",LRIDT,"NPC")=1 Indicates this record has been

 +3       ; converted to File 200. This node is used when restoring arc records.

 +4       ; "NPC")=2 indicates record processed but no provider number

 +5        NEW LRSB,LRZD1,LRPRV

 +6        SET LRSB(0)="MI"

 +7        SET LRZD1=0

           FOR 

               SET LRZD1=$ORDER(^LAR("Z",LRZD0,"MI",LRZD1))

               IF 'LRZD1

                   QUIT 

               Begin DoDot:1

 +8                IF $DATA(^LAR("Z",LRZD0,"MI",LRZD1,"NPC"))#2

                       QUIT 

 +9                SET LRPRV=$PIECE($GET(^LAR("Z",LRZD0,"MI",LRZD1,0)),U,7)

 +10               IF 'LRPRV

                       SET ^LAR("Z",LRZD0,"MI",LRZD1,"NPC")=2

                       QUIT 

 +11               IF LRPRV

                       SET $PIECE(^LAR("Z",LRZD0,"MI",LRZD1,0),U,7)=$$PROV^LRARNPX1("63.999905,.07",LRPRV,.LRSB)

                       SET ^("NPC")=1

               End DoDot:1

 +12       QUIT 

DISP      ; to display to the user the tasked job descriptions and TASK

 +1       ; numbers for the different conversion routines

 +2        WRITE $CHAR(7),!!!,$CHAR(7),"Task # "_ZTSK,!,"with the description of '"_LRDSC_"'"

 +3        WRITE !,"has been scheduled to run "

 +4        WRITE $$DDDATE^LRAFUNC1($$CDHTFM^LRAFUNC1(ZTSK("D")),2)_".",$CHAR(7),!

 +5        KILL ZTSK,ZTDTH

 +6        QUIT 

WRAPUP    ;

 +1        KILL ZTSK,ZTDESC,ZTRTN,ZTSAVE,ZTIO,ZTDTH,%ZIS,POP,X,Y,%,%X,%Y,DIC,I

 +2        KILL LRTSK,LRD0,LRZD0,LRD1,LRZD1,LRLST,LRFILE,LRIO,LRJOB,LRDSC,LRAC,LRPRV

 +3        KILL LRSB,LRST,LRDT,LRSORT

 +4        QUIT