- LRARNPX1 ;SLC/MRH/FHS/JB0 - NEW PERSON CONVERSION FOR ^LAR("Z" ; 1/23/93
- ;;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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRARNPX1 3931 printed Jan 18, 2025@03:10:13 Page 2
- LRARNPX1 ;SLC/MRH/FHS/JB0 - NEW PERSON CONVERSION FOR ^LAR("Z" ; 1/23/93
- +1 ;;5.2;LAB SERVICE;**59,150**;Sep 27, 1994
- +2 ;
- +3 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