- LRARNPX ;SLC/MRH/FHS - NEW PERSON CONVERSION FOR ^LAR("Z" ; 1/23/93
- ;;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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRARNPX 2917 printed Jan 18, 2025@03:10:12 Page 2
- LRARNPX ;SLC/MRH/FHS - NEW PERSON CONVERSION FOR ^LAR("Z" ; 1/23/93
- +1 ;;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