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