Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRARNPX

LRARNPX.m

Go to the documentation of this file.
  1. LRARNPX ;SLC/MRH/FHS - NEW PERSON CONVERSION FOR ^LAR("Z" ; 1/23/93
  1. ;;5.2;LAB SERVICE;**59,150**;Sep 27, 1994
  1. EN ;
  1. I ('$G(DUZ)!('$D(DUZ(0)))) W !!?10,$C(7),"Please do ^XUP ",!! Q
  1. N LRZD0,LRAC,LRDSC,LRDT,LRIO,LRJOB,X,ZTSK
  1. D DEVICE^LRARNPX0 I LRIO="POP" Q
  1. D QUE
  1. D WRAPUP
  1. Q
  1. DQ ;
  1. Q:'$D(ZTQUEUED)
  1. N LRZD0,LRFILE,LRLST,LRTSK
  1. S LRFILE="LAR-63.9999",LRZD0=0,(LRST,LRJOB)=1,LRTSK=$G(ZTSK)
  1. ; ^XTMP("LR52","LAR-63.9999",LRJOB,0) is the last record converted successfully
  1. K ^XTMP("LR52",LRFILE),^XTMP("LR52TIME",LRFILE)
  1. S ^XTMP("LR52",LRFILE,LRJOB,0)=0
  1. S ^XTMP("LR52TIME",LRFILE,LRJOB)=$$NOW^LRAFUNC1
  1. F S LRLST=LRZD0,LRZD0=+$O(^LAR("Z",LRZD0)) Q:LRZD0<1 D
  1. . D CH,MI
  1. . S ^XTMP("LR52",LRFILE,LRJOB,0)=LRZD0
  1. S $P(^XTMP("LR52TIME",LRFILE,LRJOB),U,2)=$$NOW^LRAFUNC1
  1. D OUT^LRARNPX1
  1. D WRAPUP
  1. Q
  1. QUE ;
  1. ; Task off JOB to convert file 63.9999
  1. S ZTIO=""
  1. S (LRDSC,ZTDESC)="LAB Conversion File 63.9999 (ARCHIVED LR DATA)"
  1. S ZTSAVE("LRIO")=LRIO,ZTRTN="DQ^LRARNPX" D ^%ZTLOAD,DISP
  1. Q
  1. CH ; change pointers in CHEM HEM, TOX, RIA, SER, etc. subfile 63.999904
  1. ; sub("CH") Change REQUESTING PERSON field .1 pointer
  1. ; ^LAR("Z",LRDFN,"CH",LRIDT,"NPC")=1 Indicates this record has been
  1. ;converted to File 200. This node is used when restoring arch records.
  1. ; "NPC")=2 indicates record processed but no provider number
  1. N LRSB,LRZD1,LRPRV
  1. S LRSB(0)="CH"
  1. S LRZD1=0 F S LRZD1=$O(^LAR("Z",LRZD0,"CH",LRZD1)) Q:'LRZD1 D
  1. . Q:$D(^LAR("Z",LRZD0,"CH",LRZD1,"NPC"))#2
  1. . S LRD0=$G(^LAR("Z",LRZD0,"CH",LRZD1,0)),LRPRV=$P(LRD0,U,10)
  1. . I 'LRPRV S ^LAR("Z",LRZD0,"CH",LRZD1,"NPC")=2 Q
  1. . I LRPRV D
  1. .. S $P(LRD0,U,10)=$$PROV^LRARNPX1("63.999904,.1",LRPRV,.LRSB)
  1. .. S ^LAR("Z",LRZD0,"CH",LRZD1,0)=LRD0,^("NPC")=1
  1. Q
  1. MI ; change pointers in MICROBIOLOGY subfile 63.999905
  1. ; sub("MI") Change PHYSICIAN field .07 pointer
  1. ; ^LAR("Z",LRDFN,"MI",LRIDT,"NPC")=1 Indicates this record has been
  1. ; converted to File 200. This node is used when restoring arc records.
  1. ; "NPC")=2 indicates record processed but no provider number
  1. N LRSB,LRZD1,LRPRV
  1. S LRSB(0)="MI"
  1. S LRZD1=0 F S LRZD1=$O(^LAR("Z",LRZD0,"MI",LRZD1)) Q:'LRZD1 D
  1. . Q:$D(^LAR("Z",LRZD0,"MI",LRZD1,"NPC"))#2
  1. . S LRPRV=$P($G(^LAR("Z",LRZD0,"MI",LRZD1,0)),U,7)
  1. . I 'LRPRV S ^LAR("Z",LRZD0,"MI",LRZD1,"NPC")=2 Q
  1. . I LRPRV S $P(^LAR("Z",LRZD0,"MI",LRZD1,0),U,7)=$$PROV^LRARNPX1("63.999905,.07",LRPRV,.LRSB),^("NPC")=1
  1. Q
  1. DISP ; to display to the user the tasked job descriptions and TASK
  1. ; numbers for the different conversion routines
  1. W $C(7),!!!,$C(7),"Task # "_ZTSK,!,"with the description of '"_LRDSC_"'"
  1. W !,"has been scheduled to run "
  1. W $$DDDATE^LRAFUNC1($$CDHTFM^LRAFUNC1(ZTSK("D")),2)_".",$C(7),!
  1. K ZTSK,ZTDTH
  1. Q
  1. WRAPUP ;
  1. K ZTSK,ZTDESC,ZTRTN,ZTSAVE,ZTIO,ZTDTH,%ZIS,POP,X,Y,%,%X,%Y,DIC,I
  1. K LRTSK,LRD0,LRZD0,LRD1,LRZD1,LRLST,LRFILE,LRIO,LRJOB,LRDSC,LRAC,LRPRV
  1. K LRSB,LRST,LRDT,LRSORT
  1. Q