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

LRARNPX1.m

Go to the documentation of this file.
  1. LRARNPX1 ;SLC/MRH/FHS/JB0 - NEW PERSON CONVERSION FOR ^LAR("Z" ; 1/23/93
  1. ;;5.2;LAB SERVICE;**59,150**;Sep 27, 1994
  1. ;
  1. Q
  1. PROV(LRFLD,X1,LRSB) ;
  1. ; X1 = Pointer value of data that pointed to FILE 16
  1. ; LRFLD = field number or if in a subfile subfile number,field number
  1. ; quits with the new value pointer from file 200 or logs an exception
  1. ; in ^XTMP("LR52","global root",LRJOB #,subscript 1,LRZD0,field number)
  1. ; =error and quits with the old value concantenated with "ERR"
  1. ; LRSB is an array that carries all subscripts from the file in
  1. ; which the conversion is being done.
  1. N X,Y,LRNAM
  1. S X=$G(X1)
  1. S LRNAM=$P($G(^VA(200,$O(^VA(200,"A16",X,0)),0)),U)
  1. I '$L(LRNAM) S LRNAM="Non-existant" D POINT(LRFLD,X,LRNAM,.LRSB) G NOP
  1. S Y=$O(^VA(200,"A16",X,0)) I 'Y D POINT(LRFLD,X,LRNAM,.LRSB) G NOP
  1. Q Y
  1. NOP ;
  1. Q "ERR"_X1
  1. ;
  1. POINT(LRFLD,Y,LRNAM,LRSB) ;
  1. ; LRFLD - documented at line tag PROV
  1. ; Y = value from data the should be entry in ^VA(200,Y))
  1. ; LRNAM is the externalization of the person/provider pointer from 16
  1. ; LRSB is an array with subscript identifiers LRSB(0) first level
  1. ; LRSB(1) second level ....
  1. ;
  1. I '$G(LRZD1) S ^XTMP("LR52",LRFILE,LRJOB,LRZD0,LRSB(0),LRFLD)=Y_U_LRNAM D EXCEPT^LRARNPX0(LRFILE,LRZD0) Q
  1. I '$G(LRZD2) S ^XTMP("LR52",LRFILE,LRJOB,LRZD0,LRSB(0),LRZD1,LRFLD)=Y_U_LRNAM D EXCEPT^LRARNPX0(LRFILE,LRZD0) Q
  1. S ^XTMP("LR52",LRFILE,LRJOB,LRZD0,LRSB(0),LRZD1,LRSB(1),LRZD2,LRFLD)=Y_U_LRNAM D EXCEPT^LRARNPX0(LRFILE,LRZD0)
  1. Q
  1. ;
  1. OUT ;
  1. I $D(LRIO) D REQUE Q
  1. ;
  1. REENT ; re-entry for reque if LRIO is busy from above
  1. ;
  1. D HEAD^LRARNPX0(LRFILE)
  1. I '$O(^XTMP("LR52",LRFILE,LRJOB,0)) W !!?(IOM-$L("**** none found ****"))\2,"**** NONE FOUND ****"
  1. F LRD0=0:0 S LRD0=$O(^XTMP("LR52",LRFILE,LRJOB,LRD0)) Q:LRD0'>0 S LRD0(0)=$G(^LR(LRD0,0)) F LRSB=".2","AU","BB","CH","CY","EM","MI","SP" D 1
  1. W @IOF D ^%ZISC
  1. K LRAC,LRD0,LRD1,LRFILE,LRFLD,LRJOB,LRSB,LRSF,LRST,LRTI,LRTIT,LRVL
  1. K LRIO,LRNAM,LRZD0,LRZD1,LRZD2,X,X1,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
  1. Q
  1. 1 ;
  1. I LRSB=.2 D 11 Q
  1. WRITE ;
  1. Q:'$D(^XTMP("LR52",LRFILE,LRJOB,LRD0,LRSB))
  1. S LRD1=$O(^XTMP("LR52",LRFILE,LRJOB,LRD0,LRSB,0))
  1. S LRFLD=$O(^XTMP("LR52",LRFILE,LRJOB,LRD0,LRSB,LRD1,0)) Q:LRFLD=""
  1. S LRVL=$G(^XTMP("LR52",LRFILE,LRJOB,LRD0,LRSB,LRD1,LRFLD))
  1. I LRFLD["," S LRTIT=$P($G(@("^DD("_LRFLD_",0)")),U)
  1. I LRFLD'["," S LRTIT=$P($G(@("^DD("_$P(LRFILE,"-",2)_","_LRFLD_",0)")),U)
  1. S LRD0(0)=$G(^LR(LRD0,0))
  1. I LRSB="AU" S LRD1(0)=$G(^LR(LRD0,"AU")),LRSF="AUTOPSY" D WRIT1 Q
  1. I LRSB="BB" S LRD1(0)=$G(^LR(LRD0,"BB",LRD1,0)),LRSF="BLOOD BANK" D WRIT1 Q
  1. I LRSB="CH" S LRD1(0)=$G(^LR(LRD0,"CH",LRD1,0)),LRSF="CHEM, HEM, TOX, RIA, SER, etc." D WRIT1 Q
  1. I LRSB="CY" S LRD1(0)=$G(^LR(LRD0,"CY",LRD1,0)),LRSF="CYTOPATHOLOGY" D WRIT1 Q
  1. I LRSB="EM" S LRD1(0)=$G(^LR(LRD0,"EM",LRD1,0)),LRSF="EM" D WRIT1 Q
  1. I LRSB="MI" S LRD1(0)=$G(^LR(LRD0,"MI",LRD1,0)),LRSF="MICROBIOLOGY" D WRIT1 Q
  1. I LRSB="SP" S LRD1(0)=$G(^LR(LRD0,"SP",LRD1,0)),LRSF="SURGICAL PATHOLOGY" D WRIT1 Q
  1. Q
  1. ;
  1. 11 ;
  1. Q:'$D(^XTMP("LR52",LRFILE,LRJOB,LRD0,LRSB))
  1. S LRFLD=$O(^XTMP("LR52",LRFILE,LRJOB,LRD0,LRSB,0)),LRVL=$G(^(LRFLD))
  1. I LRFLD["," S LRTIT=$P($G(@("^DD("_LRFLD_",0)")),U)
  1. I LRFLD'["," S LRTIT=$P($G(@("^DD("_$P(LRFILE,"-",2)_","_LRFLD_",0)")),U)
  1. I ($Y+10)>IOSL D HEAD^LRARNPX0(LRFILE)
  1. W !!!,"The value ("_+LRVL_") """_$P(LRVL,U,2)_""",",!,"in field "_LRTIT_", could not be repointed.",!,"This occured in: ",LRD0
  1. Q
  1. WRIT1 ;
  1. I ($Y+10)>IOSL D HEAD^LRARNPX0(LRFILE)
  1. W !!!,"The value ("_+LRVL_") """_$P(LRVL,U,2)_""",",!,"in field "_LRTIT_", could not be repointed.",!,"This occured in: ",LRD0,!,"The "_LRSF_": subfile of """,LRSB,"""",?54,"entry: "_LRD1
  1. Q
  1. ;
  1. REQUE ; reque task to print out exceptions
  1. N I
  1. S ZTIO=LRIO,ZTDESC="Requeue of exception report FILE 63 conversion JOB "_LRJOB,ZTDTH=$H,ZTRTN="REENT^LRARNPX1"
  1. F I="LRFILE","LRJOB","LRST","LRAC","LRTSK" S ZTSAVE(I)=""
  1. D ^%ZTLOAD Q