source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRARNPX1.m@ 1604

Last change on this file since 1604 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1LRARNPX1 ;SLC/MRH/FHS/JB0 - NEW PERSON CONVERSION FOR ^LAR("Z" ; 1/23/93
2 ;;5.2;LAB SERVICE;**59,150**;Sep 27, 1994
3 ;
4 Q
5PROV(LRFLD,X1,LRSB) ;
6 ; X1 = Pointer value of data that pointed to FILE 16
7 ; LRFLD = field number or if in a subfile subfile number,field number
8 ; quits with the new value pointer from file 200 or logs an exception
9 ; in ^XTMP("LR52","global root",LRJOB #,subscript 1,LRZD0,field number)
10 ; =error and quits with the old value concantenated with "ERR"
11 ; LRSB is an array that carries all subscripts from the file in
12 ; which the conversion is being done.
13 N X,Y,LRNAM
14 S X=$G(X1)
15 S LRNAM=$P($G(^VA(200,$O(^VA(200,"A16",X,0)),0)),U)
16 I '$L(LRNAM) S LRNAM="Non-existant" D POINT(LRFLD,X,LRNAM,.LRSB) G NOP
17 S Y=$O(^VA(200,"A16",X,0)) I 'Y D POINT(LRFLD,X,LRNAM,.LRSB) G NOP
18 Q Y
19NOP ;
20 Q "ERR"_X1
21 ;
22POINT(LRFLD,Y,LRNAM,LRSB) ;
23 ; LRFLD - documented at line tag PROV
24 ; Y = value from data the should be entry in ^VA(200,Y))
25 ; LRNAM is the externalization of the person/provider pointer from 16
26 ; LRSB is an array with subscript identifiers LRSB(0) first level
27 ; LRSB(1) second level ....
28 ;
29 I '$G(LRZD1) S ^XTMP("LR52",LRFILE,LRJOB,LRZD0,LRSB(0),LRFLD)=Y_U_LRNAM D EXCEPT^LRARNPX0(LRFILE,LRZD0) Q
30 I '$G(LRZD2) S ^XTMP("LR52",LRFILE,LRJOB,LRZD0,LRSB(0),LRZD1,LRFLD)=Y_U_LRNAM D EXCEPT^LRARNPX0(LRFILE,LRZD0) Q
31 S ^XTMP("LR52",LRFILE,LRJOB,LRZD0,LRSB(0),LRZD1,LRSB(1),LRZD2,LRFLD)=Y_U_LRNAM D EXCEPT^LRARNPX0(LRFILE,LRZD0)
32 Q
33 ;
34OUT ;
35 I $D(LRIO) D REQUE Q
36 ;
37REENT ; re-entry for reque if LRIO is busy from above
38 ;
39 D HEAD^LRARNPX0(LRFILE)
40 I '$O(^XTMP("LR52",LRFILE,LRJOB,0)) W !!?(IOM-$L("**** none found ****"))\2,"**** NONE FOUND ****"
41 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
42 W @IOF D ^%ZISC
43 K LRAC,LRD0,LRD1,LRFILE,LRFLD,LRJOB,LRSB,LRSF,LRST,LRTI,LRTIT,LRVL
44 K LRIO,LRNAM,LRZD0,LRZD1,LRZD2,X,X1,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
45 Q
461 ;
47 I LRSB=.2 D 11 Q
48WRITE ;
49 Q:'$D(^XTMP("LR52",LRFILE,LRJOB,LRD0,LRSB))
50 S LRD1=$O(^XTMP("LR52",LRFILE,LRJOB,LRD0,LRSB,0))
51 S LRFLD=$O(^XTMP("LR52",LRFILE,LRJOB,LRD0,LRSB,LRD1,0)) Q:LRFLD=""
52 S LRVL=$G(^XTMP("LR52",LRFILE,LRJOB,LRD0,LRSB,LRD1,LRFLD))
53 I LRFLD["," S LRTIT=$P($G(@("^DD("_LRFLD_",0)")),U)
54 I LRFLD'["," S LRTIT=$P($G(@("^DD("_$P(LRFILE,"-",2)_","_LRFLD_",0)")),U)
55 S LRD0(0)=$G(^LR(LRD0,0))
56 I LRSB="AU" S LRD1(0)=$G(^LR(LRD0,"AU")),LRSF="AUTOPSY" D WRIT1 Q
57 I LRSB="BB" S LRD1(0)=$G(^LR(LRD0,"BB",LRD1,0)),LRSF="BLOOD BANK" D WRIT1 Q
58 I LRSB="CH" S LRD1(0)=$G(^LR(LRD0,"CH",LRD1,0)),LRSF="CHEM, HEM, TOX, RIA, SER, etc." D WRIT1 Q
59 I LRSB="CY" S LRD1(0)=$G(^LR(LRD0,"CY",LRD1,0)),LRSF="CYTOPATHOLOGY" D WRIT1 Q
60 I LRSB="EM" S LRD1(0)=$G(^LR(LRD0,"EM",LRD1,0)),LRSF="EM" D WRIT1 Q
61 I LRSB="MI" S LRD1(0)=$G(^LR(LRD0,"MI",LRD1,0)),LRSF="MICROBIOLOGY" D WRIT1 Q
62 I LRSB="SP" S LRD1(0)=$G(^LR(LRD0,"SP",LRD1,0)),LRSF="SURGICAL PATHOLOGY" D WRIT1 Q
63 Q
64 ;
6511 ;
66 Q:'$D(^XTMP("LR52",LRFILE,LRJOB,LRD0,LRSB))
67 S LRFLD=$O(^XTMP("LR52",LRFILE,LRJOB,LRD0,LRSB,0)),LRVL=$G(^(LRFLD))
68 I LRFLD["," S LRTIT=$P($G(@("^DD("_LRFLD_",0)")),U)
69 I LRFLD'["," S LRTIT=$P($G(@("^DD("_$P(LRFILE,"-",2)_","_LRFLD_",0)")),U)
70 I ($Y+10)>IOSL D HEAD^LRARNPX0(LRFILE)
71 W !!!,"The value ("_+LRVL_") """_$P(LRVL,U,2)_""",",!,"in field "_LRTIT_", could not be repointed.",!,"This occured in: ",LRD0
72 Q
73WRIT1 ;
74 I ($Y+10)>IOSL D HEAD^LRARNPX0(LRFILE)
75 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
76 Q
77 ;
78REQUE ; reque task to print out exceptions
79 N I
80 S ZTIO=LRIO,ZTDESC="Requeue of exception report FILE 63 conversion JOB "_LRJOB,ZTDTH=$H,ZTRTN="REENT^LRARNPX1"
81 F I="LRFILE","LRJOB","LRST","LRAC","LRTSK" S ZTSAVE(I)=""
82 D ^%ZTLOAD Q
Note: See TracBrowser for help on using the repository browser.