LRNPXA ; IHS/DIR/FJE - NEW PERSON CONVERSION FOR ^LAR("Z" ; [ 1/23/93 ]
;;5.2;LR;;NOV 01, 1997
;
;;5.2;LAB SERVICE;;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^LRNPXA0 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^LRNPXA1
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^LRNPXA" 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^LRNPXA1("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^LRNPXA1("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 schedlued 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
LRNPXA ; IHS/DIR/FJE - NEW PERSON CONVERSION FOR ^LAR("Z" ; [ 1/23/93 ]
+1 ;;5.2;LR;;NOV 01, 1997
+2 ;
+3 ;;5.2;LAB SERVICE;;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^LRNPXA0
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^LRNPXA1
+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^LRNPXA"
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^LRNPXA1("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^LRNPXA1("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 schedlued 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
