8:53 AM  1-DEC-97
LR 5.1 Patch 05 Conversion Routines 11/1/97fje
LR5XCNV
LR5XCNV ; IHS/DIR/FJE - DRIVER FOR THE LAB DATA CONVERSION TO FILE 200 ;
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
PRE ;This line will shorten the actual installation time. A print
 ;out of the CAP code file is provided here.
 D EXPLAIN^LR5XCNVD
 S LREND=0
 D DIR1^LR5XCNVD I $G(LREND) D END QUIT
 D ^LR5XCNVX
EN N D0,LRAC,LRDSC,LRDT,LRIO,LRJOB,X,ZTSK
 D DEVICE^LR5XCNV0 I LRIO="POP" K LRIO Q
 K ^XTMP("LR5XTIME"),^LR("TMP"),^XTMP("LR5X")
 S LRALL=1
 D 63,65,68,69,ARCH
 D ^%ZISC W !,?10,"Completed tasking all conversion routines ",!!
 K LRALL,LRNEWAY
 Q
DIR1 ;
 D DIR1^LR5XCNVD
 Q
END ;
 K LRIO,LRIO1,LRNEWAY S LREND=0 D ^%ZISC
 Q
EN63 ; Entry point for ^LR( conversion only
 S LREND=0
 I '$G(^LAB(60,"PREINIT")) D ^LR5XCNVX
 D DIR1 I $G(LREND) D END QUIT
 D DEVICE^LR5XCNV0 I LRIO="POP" D END Q
63 ;
 ; Task off MULTIPLE JOBS to convert file 63
 Q:$$CHK(63,"LR-63")
 S LRJOB=0
 F D0=0:30000 Q:$O(^LR(D0))'>0  D LOAD63
 Q
EN65 ; Entry point for ^LRD(65 conversion only
 S LREND=0
 I '$G(^LAB(60,"PREINIT")) D ^LR5XCNVX
 D DIR1 I $G(LREND) D END QUIT
 D DEVICE^LR5XCNV0 I LRIO="POP" K LRIO Q
65 ;
 ; Task off JOB to convert file 65
 Q:$$CHK(65,"LAB-65")
 S ZTIO="" S:$D(LRNEWAY) ZTIO=LRIO1 S ZTDTH=$H,(LRDSC,ZTDESC)="LAB Conversion File 65 (BLOOD INVENTORY)",ZTSAVE("LRIO")=LRIO,ZTRTN="LR5XCNV5"
 D ^%ZTLOAD,DISP
 I 'LRALL K LRNEWAY
 Q
ENARCH ; Entry point for ^LR(63.9999 conversion only
 S LREND=0
 I '$G(^LAB(60,"PREINIT")) D ^LR5XCNVX
 D DIR1 I $G(LREND) D END QUIT
 D DEVICE^LR5XCNV0 I LRIO="POP" K LRIO Q
ARCH ;
 ; Task off JOB to convert file 63.9999
 Q:$$CHK(63.9999,"LAR-63.9999")
 S ZTIO="" S:$D(LRNEWAY) ZTIO=LRIO1 S ZTDTH=$H,(LRDSC,ZTDESC)="LAB Conversion File 63.9999 (ARCHIVED LR DATA)",ZTSAVE("LRIO")=LRIO,ZTRTN="LR5XCNVA" D ^%ZTLOAD,DISP
 I 'LRALL K LRNEWAY
 Q
EN68 ; Entry point for ^LRO(68 conversion only
 S LREND=0
 I '$G(^LAB(60,"PREINIT")) D ^LR5XCNVX
 D DIR1 I $G(LREND) D END QUIT
 D DEVICE^LR5XCNV0 I LRIO="POP" K LRIO Q
68 ;
 ; Task off MULTIPLE JOB to convert file 68
 Q:$$CHK(68,"LRO-68")
 K ZTIO,ZTSAVE,ZTSK,ZTDESC
 F LRAC=0:0 S LRAC=$O(^LRO(68,LRAC)) Q:LRAC'>0  D LOAD68
 Q
EN69 ; Entry point for ^LRO(69 conversion only
 S LREND=0
 I '$G(^LAB(60,"PREINIT")) D ^LR5XCNVX
 D DIR1 I $G(LREND) D END QUIT
 D DEVICE^LR5XCNV0 I LRIO="POP" K LRIO Q
69 ;
 ; Task off MULTIPLE JOBS to convert file 69
 Q:$$CHK(69,"LRO-69")
 K ZTIO,ZTSAVE,ZTSK,ZTDESC
 S LRDT=+$O(^LRO(69,2831231)) Q:'LRDT  F LRDT=LRDT:10000 Q:'+$O(^LRO(69,LRDT))!(LRDT>2950000)  D LOAD69
 Q
 ;
 ;
DISP ; to display to the user the tasked job descriptions and TASK
 ; numbers for the different conversion routines
 W $C(7),!!!,$C(7),"Task # "_ZTSK,!,"with the description of '"_LRDSC_"'",!,"has been scheduled to run "_$$DDDATE^LR5XCNV1($$CDHTFM^LR5XCNV1(ZTSK("D")),2)_".",$C(7),!
 K ZTSK
 Q
 ;
LOAD63 ;
 S LRJOB=LRJOB+1,ZTIO="" S ZTDTH=$H,(LRDSC,ZTDESC)="LAB Conversion File 63 (LAB DATA) global from ENTRY # "_D0_" to ENTRY # "_(D0+29999)_"."
 I $D(LRNEWAY) S ZTIO=LRIO1
 S ZTSAVE("LRJOB")="",ZTSAVE("D0")=D0-1,ZTSAVE("LRIO")=LRIO,ZTRTN="LR5XCNV3"
 D ^%ZTLOAD,DISP
 I 'LRALL K LRNEWAY
 Q
 ;
LOAD68 ;
 S (LRDSC,ZTDESC)="LAB Conversion File 68 (ACCESSION) area # "_LRAC_".",ZTIO="",ZTDTH=$H
 I $D(LRNEWAY) S ZTIO=LRIO1
 S ZTSAVE("LRAC")=LRAC,ZTSAVE("LRIO")=LRIO,ZTRTN="LR5XCNV8"
 D ^%ZTLOAD,DISP
 I 'LRALL K LRNEWAY
 Q
 ;
LOAD69 ;
 S ZTDTH=$H S:'$D(LRNEWAY) ZTIO="" S (LRDSC,ZTDESC)="LAB Conversion of File 69 (LAB ORDER) "_$$DDDATE^LR5XCNV1(LRDT,0)
 I $D(LRNEWAY) S ZTIO=LRIO1
 S ZTRTN="EN^LR5XCNV9",ZTSAVE("LRDT")=LRDT,ZTSAVE("LRIO")=LRIO D ^%ZTLOAD,DISP
 I 'LRALL K LRNEWAY
 Q
 ;
CRASH ; restart point for conversion after unexpected process interupt
 ; If you have any questions about this process please refer to the
 ; Troubleshooting section of your patch documentation.
 N LRESTRT
 S LRESTRT=1 G EN
 Q
 ;
CHK(X,Y) ;
 I $G(^DD(X,0,"VR"))<5.15 Q 0
 I $G(^DD(X,0,"VR"))=5.14&($G(LRESTRT))&($D(^XTMP("LR5X",Y))) Q 0
 W !!,"Conversion of the data in file "_X_" ABORTED,",!,"from the version number on the file it appears to have already been run." Q 1

LR5XCNV0
DHZCNV0 ; IHS/DIR/FJE - UTILITIES FOR 5.2 DATA CONVERSION ;
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
 ;
 Q
PROV(LRFLD,X1,LRSB) ;
 ;  X1 = Pointer value of data that pointed to in FILE 16
 ;  LRFLD = field number, or if in a subfile, subfile number,field number
 ;  Variable LRFILE must be defined at entry and has form LRO(68 = LRO-68
 ;  ^LR( would take the form LR-63.
 ;  quits with the new value pointer from file 200
 ;  or logs an exception in ^XTMP("LR5X","global root",D0,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. LRSB(0)="CH",LRSB(1)=1
 ;  would cover ^LR(D0,"CH",D1,1,D2,0) as an example
 D DT^DICRW D:'$D(IOF) HOME^%ZIS
 N X,Y,LRNAM
 S X=+$G(X1)
 S LRNAM=$P($G(^DIC(16,X,0)),U)
 I '$L(LRNAM) S LRNAM="Non-existent" D POINT(LRFLD,X,LRNAM,.LRSB) Q X1_"ERR"
 I '$D(^DIC(16,X1,"A3"))#2 D POINT(LRFLD,X,LRNAM,.LRSB) Q X1_"ERR"
 S Y=$G(^DIC(16,X1,"A3")) I 'Y D POINT(LRFLD,X,LRNAM,.LRSB) Q X1_"ERR" ; naked to DIC(16,X,"A3")
 Q Y
 ;
POINT(LRFLD,Y,LRNAM,LRSB) ;
 ; LRFLD - documented at line tag PROV
 ; Y = value from data the should be entry in ^DIC(16,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(D1) S ^XTMP("LR5X",LRFILE,D0,LRSB(0),LRFLD)=Y_U_LRNAM D EXCEPT(LRFILE,D0) Q
 I '$G(D2) S ^XTMP("LR5X",LRFILE,D0,LRSB(0),D1,LRFLD)=Y_U_LRNAM D EXCEPT(LRFILE,D0) Q
 S ^XTMP("LR5X",LRFILE,D0,LRSB(0),D1,LRSB(1),D2,LRFLD)=Y_U_LRNAM D EXCEPT(LRFILE,D0)
 Q
 ;
 ;
 ;
EXCEPT(LRFILE,LRD0) ;- LOGS EXCEPTIONS FROM THE CONVERSIONS OF DATA FROM 6 AND 16
 ; exceptions are put into a SORT template so the the site can
 ; then use fileman enter edit to correct problems found.
 ;
 N DIC,LRSORT,X,Y
 I '$D(^DIBT("B",LRFILE_"-EXCEPTIONS")) D ADD
 I '$D(LRSORT) S LRSORT=$O(^DIBT("B",LRFILE_"-EXCEPTIONS",0))
 S ^DIBT(LRSORT,1,LRD0)=""
 Q
 ;
ADD ; add a new sort template to be used for exception logging and editing
 N X,Y
 S DIC="^DIBT(",DIC(0)="L",DLAYGO=.401,DIC("DR")="2///^S X=""T"";4///^S X=$P(LRFILE,""-"",2);5///^S X=0;"
 S X=LRFILE_"-EXCEPTIONS" D FILE^DICN S LRSORT=+Y
 Q
 ;
DEVICE ; device selection for exception report for file conversions
 K %ZIS
 S %ZIS="N",%ZIS("A")="PRINTER for EXCEPTION REPORT: ",%ZIS("B")="" D ^%ZIS
 I 'POP&(IOST?1"P-".E) S LRIO=ION D:$D(LRNEWAY) THROTTLE Q
 I POP S LRIO="POP" Q
 W !!,"A DEVICE must be chosen for the EXCEPTION report to print on",!,"That is defined as a """"P-"""" something.",!! G DEVICE
 Q
THROTTLE ;
 K DIC
 S DIC=3.54
 S DIC(0)="AEMQZ"
 D ^DIC
 I $D(DTOUT)!$D(DUOUT) S LREND=1 Q
 ;W !,"Enter THROTTLE device.",! D ^%ZIS
 ;I POP S LRIO="POP" Q
 S LRIO1=$P(Y,U,2)
 Q
 ;
HEAD(X) ; writes header for all exception reports
 N LRTIT
 S LRTIT=$P($G(^DIC($P(X,"-",2),0)),U),LRTIT="Exception report for file "_$P(X,"-",2)_":  "_LRTIT_"."
 W !,?(IOM-$L(LRTIT))\2,LRTIT
 S LRTIT=$G(LRTSK) I LRTIT S LRTIT="Task # "_LRTIT W !,?(IOM-$L(LRTIT))\2,LRTIT

LR5XCNV1
LR5XCNV1 ; IHS/DIR/FJE - Callable DATE-TIME functions ;
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
 ;;
 ;
 N I,X
 W !!,"Routine: "_$T(+0),! F I=8:1  S X=$T(LR5XCNV1+I) Q:'$L(X)  I X[";;" W !,X
 W !!
 Q
 ;
DT() ;; $$VAR
 ;; Returns current Date in Fileman form
 ;; YYYMMDD
 ;; Eg.  S DT=$$DT^LR5XCNV1
 Q $$NOW\1
 ;;
NOW() ;; $$VAR
 ;; Returns Date-Time in Fileman form
 ;; YYYMMDD.HHMMSS
 ;; Eg.  S X=$$NOW^LR5XCNV1
 Q $$CDHTFM($H)
 ;;
DOW(X) ;;
 ;; Call by value
 ;; X is in $H or Fileman form
 ;; Returns string day of week
 ; Help from DIDTC
 N LRCENT,LRCENTD,LRCENTH,LRCENTM,LRCENTT,LRCENTY
 I X'?7N.E S X=$$CDHTFM(X)
 D COMP
 Q $P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR","^",LRCENTY+1)_"DAY"
 ;;
CDHTFM(X1) ;; convert $H Date-Time to Fileman Date-Time form
 ;; Call by value
 ;; X = Date-Time in $H format NNNNN,NNNNN
 ;; Returns Date-Time in Fileman format YYYMMDD.HHMMSS
 ;; eg. S X=$$CDHTFM($H)
 ; help from DIDTC
 N X,LRCENT,LRCENTD,LRCENTI,LRCENTM,LRCENTY
 S LRCENT=X1>21608+X1-.1,LRCENTY=LRCENT\365.25+141,LRCENT=LRCENT#365.25\1
 S LRCENTD=LRCENT+306#(LRCENTY#4=0+365)#153#61#31+1,LRCENTM=LRCENT-LRCENTD\29+1
 S X=LRCENTY_"00"+LRCENTM_"00"+LRCENTD
 S LRCENTI(1)=LRCENTM,LRCENTI(2)=LRCENTD,LRCENTI(3)=LRCENTY
 S LRCENT=$P(X1,",",2)
 S LRCENT=LRCENT#60/100+(LRCENT#3600\60)/100+(LRCENT\3600)/100
 S LRCENT=X_$S(LRCENT:LRCENT,1:"")
 Q LRCENT
 ;;
CFMTDH(X) ;; converts Fileman Date-Time to $H Date-time
 ;; Call by value
 ;; D = Date-Time in Fileman form  YYYMMDD.HHMMSS
 ;; Returns Date-Time in $H form  NNNNN,NNNNN
 ;; eg.  S X=$$CFMTDH(2901225.1234)
 ; Help from DIDTC
 N LRCENT,LRCENTD,LRCENTH,LRCENTM,LRCENTT,LRCENTY
 I X<1410000 Q 0
 D COMP
 I LRCENTT>86400 S LRCENTT=LRCENTT-86400,D1=1
 S LRCENTH=LRCENTH+$G(D1)
 Q LRCENTH_","_LRCENTT
 ;;
DDDATE(Y1,Y2) ;;
 ;; $$DDDATE(Y1,Y2)
 ;; Call by value
 ;; Y1 Date-Time in Fileman Format
 ;; Returns External form of Date-Time MMM DD,YYYY (@HH:MM:SS) depending
 ;; on the value of Y2
 ;; if Y1 is NOT passed $$NOW^LR5XCNV1 will be used for the date
 ;; if Y2=0 no time will return
 ;; if Y2=1 time will be returned in hours and minutes
 ;; if Y2=2 time will be returned in hours, minutes and seconds
 ;  with help from DD^DIDT
 N Y
 I '$G(Y1) S Y1=$$NOW
 S Y=$S($E(Y1,4,5):$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$E(Y1,4,5))_" ",1:"")_$S($E(Y1,6,7):+$E(Y1,6,7)_",",1:"")_($E(Y1,1,3)+1700) Q:'$G(Y2) Y
 S Y=Y_$P("@"_$E(Y1_0,9,10)_":"_$E(Y1_"000",11,12),"^",Y1[".") Q:$G(Y2)'>1 Y
 S Y=Y_$S($E(Y1,13,14):":"_$E(Y1_0,13,14),1:"")
 Q Y
 ;;
ADDDATE(D,D1,H,M,S) ;; Adds Days, hours minutes seconds to D
 ;; D date in Fileman format to which is to be added
 ;; D1 Days * optional *
 ;; H Hours * optional *
 ;; M Minutes * optional *
 ;; S Seconds * optional *
 ;; Returns DATE in fileman Format
 ;; eg. S X=$$ADDDATE(DT,0,12) would add 12 hours to the value of DT
 N LRCENT,LRCENTD,LRCENTH,LRCENTM,LRCENTT,LRCENTY,X
 I '$G(D) Q 0
 S D1=+$G(D1),H=+$G(H),M=+$G(M),S=+$G(S)
 S LRCENTH=$$CFMTDH(D),LRCENTT=$P(LRCENTH,",",2)
 S LRCENTH=LRCENTH+D1,LRCENTT=LRCENTT+(H*3600)+(M*60)+S
 Q $$CDHTFM(LRCENTH_","_LRCENTT)
 ;;
DTC(X1,X2,X3) ;;   Date-Time Compare
 ;; Call by value
 ;; X1 and X2 the dates for comparison
 ;; X3 = 0 returns difference in whole days eg. 1
 ;; X3 = 1 return difference in days and hours eg. 1.01 or 1.14
 ;; X3 = 2 returns difference in days, hours and minutes 1.0103 or 1.1423
 ;; X3 = 3 returns difference in days, hours, minutes and seconds
 ;;      1.010234 or 1.142322
 ; Help from DIDTC
 N LRCENTD,LRCENTH,LRCENTM,LRCENTY,X12,X22,X
 I '$G(X1)!'$G(X2) Q ""
 S X=X1,X(1)=$P(X1,".",2) D COMP S X1=LRCENTH,X12=LRCENT
 S X=X2,X(1)=$P(X2,".",2) S X2=LRCENTY+1 D COMP S X22=LRCENT
 S X=X1-LRCENTH
 I $G(X3) D
 . S LRCENT=X12-X22,LRCENT=LRCENT#60/100+(LRCENT#3600\60)/100+(LRCENT\3600)/100
 . S LRCENT=$E(LRCENT,1,$S(X3=1:3,X3=2:5,1:7))
 . S X=X_LRCENT
 Q X
 ;
COMP ;
 I X<1410000 S LRCENTH=0,LRCENTY=-1 Q
 S LRCENTY=$E(X,1,3),LRCENTM=$E(X,4,5),LRCENTD=$E(X,6,7)
 S LRCENTT=$E(X_0,9,10)*60+$E(X_"000",11,12)*60+$E(X_"00000",13,14)
 S LRCENTH=LRCENTM>2&'(LRCENTY#4)+$P("^31^59^90^120^151^181^212^243^273^304^334","^",LRCENTM)+LRCENTD
 S LRCENT='LRCENTM!'LRCENTD,LRCENTY=LRCENTY-141,LRCENTH=LRCENTH+(LRCENTY*365)+(LRCENTY\4)-(LRCENTY>59)+LRCENT,LRCENTY=$S(LRCENT:-1,1:LRCENTH+4#7)
 I $G(X(1)) D
 . S LRCENT=$E(X(1)_"0",1,2)*60+$E(X(1)_"000",3,4)*60+$E(X(1)_"00000",5,6)
 Q
 ;

LR5XCNV3
LR5XCNV3 ; IHS/DIR/FJE - NEW PERSON CONVERSION FOR LAB ^LR( ;
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
 ;;
 ;
EN ;
 ; entry requires LRJOB and D0 defined.
 Q:'$D(ZTQUEUED)
 N D1,D2,LRFILE,LRLST,LRSB,LRSF,LRD0,LRD1,LRST,LRTSK
 S LRFILE="LR-63",LRTSK=$G(ZTSK)
 ;^XTMP("LR5X","LR-63",LRJOB,0) is the last record converted successfully
 S D0=$S(D0>0:D0,1:0),LRST=+D0
 I '$D(^XTMP("LR5X",LRFILE,LRJOB,0))#2&(^DD(63,0,"VR")>5.15) Q
EN1 ;
 I '$D(^XTMP("LR5X",LRFILE,LRJOB,0))#2 S ^XTMP("LR5X",LRFILE,LRJOB,0)=D0
 S D0=$G(^XTMP("LR5X",LRFILE,LRJOB,0)),^XTMP("LR5XTIME",LRFILE,LRJOB)=$$NOW^LR5XCNV1
 ;
 F  S LRLST=D0,D0=+$O(^LR(D0)) Q:D0>((LRJOB*30000)-1)!(D0<1)  D AU,BB,EM,CH,MI,^LR5XCNVU S $P(^XTMP("LR5X",LRFILE,LRJOB,0),U)=D0 W:$D(LRDEBUG) "@",D0
 K ZTSK
 S $P(^XTMP("LR5XTIME",LRFILE,LRJOB),U,2)=$$NOW^LR5XCNV1
 D OUT^LR5XCNV4
 Q
 ;
 ;
AU ; sub(.2) Change the REPORT ROUTING(PROVIDER) field .101 pointer
 ; sub("AU") Change the PHYSICIAN field 12.1 pointer
 ; sub("AU") Change the RESIDENT PATHOLOGIST field 13.5 pointer
 ; sub("AU") Change the SENIOR PATHOLOGIST field 13.6 pointer
 N LRSB
 ; ** working code I $D(^LR(D0,.1))#2 S LRFLG=^(.1),LRWD=+$O(^SC("B",LRFLG,0)) S ^LR(D0,.092)=$S('LRWD:"Z",$L($P($G(^SC(LRWD,0)),U,3)):$P(^(0),U,3),1:"Z")
 I $D(^LR(D0,.1))#2 S LRFLG=^(.1),LRWD=+$O(^SC("B",LRFLG,0)) S ^LR("TMP",LRFILE,LRJOB,.092)=$S('LRWD:"Z",$L($P($G(^SC(LRWD,0)),U,3)):$P(^(0),U,3),1:"Z")
 S LRSB(0)=.2
 S LRPRV=$G(^LR(D0,.2)) I LRPRV S ^LR("TMP",LRFILE,LRJOB)=$$PROV^LR5XCNV4(".101",LRPRV,.LRSB)
 ; ** working codeS LRPRV=$G(^LR(D0,.2)) I LRPRV S $P(^LR(D0,.2),U)=$$PROV^LR5XCNV4(".101",LRPRV,.LRSB)
 S LRSB(0)="AU"
 S LRD0=$G(^LR(D0,"AU")) I 'LRD0 Q
 S LRPRV=$P(^LR(D0,"AU"),U,12) I LRPRV S ^LR("TMP",LRFILE,LRJOB)=$$PROV^LR5XCNV4("12.1",LRPRV,.LRSB)
 S LRPRV=$P(^LR(D0,"AU"),U,7) I LRPRV S ^LR("TMP",LRFILE,LRJOB)=$$PROV^LR5XCNV4("13.5",LRPRV,.LRSB)
 S LRPRV=$P(^LR(D0,"AU"),U,10) I LRPRV S ^LR("TMP",LRFILE,LRJOB)=$$PROV^LR5XCNV4("13.6",LRPRV,.LRSB)
 ; ** working code S ^LR(D0,"AU")=LRD0
 ; ** working code S LRFLG=$P(^LR(D0,"AU"),U,3) S:LRFLG $P(^("AU"),U,15=LRFLG
 S LRFLG=$P(^LR(D0,"AU"),U,3) S:LRFLG $P(^LR("TMP",LRFILE,LRJOB),U,15)=LRFLG
 Q
 ;
 ;
BB ; change pointers in BLOOD BANK subfile 63.01
 ; sub("BB") Change PHYSICIAN field .07 pointer
 N LRSB
 S LRSB(0)="BB"
 S D1=0 F  S D1=$O(^LR(D0,"BB",D1)) Q:'D1  S LRD0=$G(^LR(D0,"BB",D1,0)),LRPRV=$P(LRD0,U,7) I LRPRV S $P(LRD0,U,7)=$$PROV^LR5XCNV4("63.01,.07",LRPRV,.LRSB) S ^LR("TMP",LRFILE,LRJOB)=$P(LRD0,U,7)
 ; **working codeS D1=0 F  S D1=$O(^LR(D0,"BB",D1)) Q:'D1  S LRD0=$G(^LR(D0,"BB",D1,0)),LRPRV=$P(LRD0,U,7) I LRPRV S $P(LRD0,U,7)=$$PROV^LR5XCNV4("63.01,.07",LRPRV,.LRSB),^LR(D0,"BB",D1,0)=LRD0
 Q
 ;
 ;
EM ; change pointers in EM subfile 63.02
 ; sub("EM") Change PTHOLOGIST field .02 pointer
 ; sub("EM") Change RESIDENT OR EMTECH field .021 pointer
 ; sub("EM") Change PHYSICIAN field .07 pointer
 N LRSB
 S LRSB(0)="EM"
 S D1=0 F  S D1=$O(^LR(D0,"EM",D1)) Q:'D1  S LRFLG=0,LRD0=$G(^LR(D0,"EM",D1,0)) D EM1
 Q
 ;
EM1 ;
 S LRPRV=$P(LRD0,U,2) I LRPRV S ^LR("TMP",LRFILE,LRJOB)=$$PROV^LR5XCNV4("63.02,.02",LRPRV,.LRSB),LRFLG=1
 S LRPRV=$P(LRD0,U,4) I LRPRV S ^LR("TMP",LRFILE,LRJOB)=$$PROV^LR5XCNV4("63.02,.021",LRPRV,.LRSB),LRFLG=1
 S LRPRV=$P(LRD0,U,7) I LRPRV S ^LR("TMP",LRFILE,LRJOB)=$$PROV^LR5XCNV4("63.02,.07",LRPRV,.LRSB),LRFLG=1
 ; ** woriking codeI LRFLG S ^LR(D0,"EM",D1,0)=LRD0
 Q
 ;
 ;
CH ; change pointers in CHEM HEM, TOX, RIA, SER, etc. subfile 63.04
 ; sub("CH") Change REQUESTING PERSON field .1 pointer
 ; ^LR(LRDFN,"CH",LRIDT,"NPC")=1 Indicates this record has been converted to File 200. This node is used when restoring archive records.
 N LRSB
 S LRSB(0)="CH"
 S D1=0 F  S D1=$O(^LR(D0,"CH",D1)) Q:'D1  S LRD0=$G(^LR(D0,"CH",D1,0)),LRPRV=$P(LRD0,U,10) I LRPRV S $P(LRD0,U,10)=$$PROV^LR5XCNV4("63.04,.1",LRPRV,.LRSB) I LRPRV W:'$D(ZTQUEUED) !,LRPRV S ^LR("TMP",LRFILE,LRJOB)=LRPRV
 ;** working code S D1=0 F  S D1=$O(^LR(D0,"CH",D1)) Q:'D1  S LRD0=$G(^LR(D0,"CH",D1,0)),LRPRV=$P(LRD0,U,10) I LRPRV S $P(LRD0,U,10)=$$PROV^LR5XCNV4("63.04,.1",LRPRV,.LRSB) I LRPRV S ^LR(D0,"CH",D1,0)=LRD0,^LR(D0,"CH",D1,"NPC")=1
 Q
 ;
 ;
MI ; change pointers in MICROBIOLOGY subfile 63.05
 ; sub("MI") Change PHYSICIAN field .07 pointer
 ; ^LR(LRDFN,"MI",LRIDT,"NPC")=1 Indicates this record has been converted to File 200. This node is used when restoring archive records.
 N LRSB
 S LRSB(0)="MI"
 S D1=0 F  S D1=$O(^LR(D0,"MI",D1)) Q:'D1  S LRPRV=$P($G(^LR(D0,"MI",D1,0)),U,7) I LRPRV S ^LR("TMP",LRFILE,LRJOB)=$$PROV^LR5XCNV4("63.05,.07",LRPRV,.LRSB)
 ;** working codeS D1=0 F  S D1=$O(^LR(D0,"MI",D1)) Q:'D1  S LRPRV=$P($G(^LR(D0,"MI",D1,0)),U,7) I LRPRV S $P(^LR(D0,"MI",D1,0),U,7)=$$PROV^LR5XCNV4("63.05,.07",LRPRV,.LRSB),^LR(D0,"MI",D1,"NPC")=1
 Q

LR5XCNV4
LR5XCNV4 ; IHS/DIR/FJE - continuation of LR5XCNV3 ;
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 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("LR5X","global root",LRJOB #,subscript 1,D0,feild 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(^DIC(16,X,0)),U)
 I '$L(LRNAM) S LRNAM="Non-existent" D POINT(LRFLD,X,LRNAM,.LRSB) G NOP
 S Y=$G(^DIC(16,X,"A3")) I 'Y D POINT(LRFLD,X,LRNAM,.LRSB)
 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 ^DIC(16,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(D1) S ^XTMP("LR5X",LRFILE,LRJOB,D0,LRSB(0),LRFLD)=Y_U_LRNAM D EXCEPT^LR5XCNV0(LRFILE,D0) Q
 I '$G(D2) S ^XTMP("LR5X",LRFILE,LRJOB,D0,LRSB(0),D1,LRFLD)=Y_U_LRNAM D EXCEPT^LR5XCNV0(LRFILE,D0) Q
 S ^XTMP("LR5X",LRFILE,LRJOB,D0,LRSB(0),D1,LRSB(1),D2,LRFLD)=Y_U_LRNAM D EXCEPT^LR5XCNV0(LRFILE,D0)
 Q
 ;
OUT ;
 I $D(LRIO) D REQUE Q
 ;
REENT ; re-entry for reque if LRIO is busy from above
 ;
 D HEAD^LR5XCNV0(LRFILE)
 S LRTI="For entries from "_LRST_" to "_((LRJOB*30000)-1)
 W !?(IOM-$L(LRTI))\2,LRTI
 I '$O(^XTMP("LR5X",LRFILE,LRJOB,0)) W !!?(IOM-$L("****  none found ****"))\2,"**** NONE FOUND ****"
 F LRD0=0:0 S LRD0=$O(^XTMP("LR5X",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
 Q
1 ;
 I LRSB=.2 D 11 Q
WRITE ;
 Q:'$D(^XTMP("LR5X",LRFILE,LRJOB,LRD0,LRSB))
 S LRD1=$O(^XTMP("LR5X",LRFILE,LRJOB,LRD0,LRSB,0))
 S LRFLD=$O(^XTMP("LR5X",LRFILE,LRJOB,LRD0,LRSB,LRD1,0)) Q:LRFLD=""
 S LRVL=$G(^XTMP("LR5X",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("LR5X",LRFILE,LRJOB,LRD0,LRSB))
 S LRFLD=$O(^XTMP("LR5X",LRFILE,LRJOB,LRD0,LRSB,0)),LRVL=$G(^XTMP("LR5X",LRFILE,LRJOB,LRD0,LRSB,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 W @IOF D HEAD^LR5XCNV0(LRFILE) W !?(IOM-$L(LRTI))\2,LRTI
 W !!!,"The value ("_+LRVL_") """_$P(LRVL,U,2)_""",",!,"in field "_LRTIT_", could not be repointed.",!,"This occurred in:"
 W !,"The LABORATORY DATA FILE:",?54,"entry: "_$P(LRD0(0),U)
 Q
WRIT1 ;
 I ($Y+10)>IOSL W @IOF D HEAD^LR5XCNV0(LRFILE) W !?(IOM-$L(LRTI))\2,LRTI
 W !!!,"The value ("_+LRVL_") """_$P(LRVL,U,2)_""",",!,"in field "_LRTIT_", could not be repointed.",!,"This occurred in:",!,"The "_LRSF_": subfile of",?54,"entry: "_$P(LRD1(0),U)
 W !,"The LABORATORY DATA FILE:",?54,"entry: "_$P(LRD0(0),U)
 Q
 ;
REQUE ; reque task to print out exceptions
 S ZTIO=LRIO,ZTDESC="Requeue of exception report FILE 63 conversion JOB "_LRJOB,ZTDTH=$H,ZTRTN="REENT^LR5XCNV4"
 F I="LRFILE","LRJOB","LRST","LRAC","LRTSK" S ZTSAVE(I)=""
 D ^%ZTLOAD Q

LR5XCNV5
LR5XCNV5 ; IHS/DIR/FJE - NEW PERSON CONVERSION FOR LAB ^LRD(65 ; 
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
 ;
EN ;
 Q:'$D(ZTQUEUED)
 N D0,D1,D2,LRFLD,LRFILE,LRTSK
 S LRFILE="LRD-65",LRTSK=$G(ZTSK)
 ;  ^XTMP("LR5X","LRD-65",0) is the last record converted successfully
 I '$D(^XTMP("LR5X",LRFILE,0))#2&(^DD(65,0,"VR")>5.15) Q
EN1 ;
 I '$D(^XTMP("LR5X",LRFILE,0))#2 S ^XTMP("LR5X",LRFILE,0)=0
 S D0=$G(^XTMP("LR5X",LRFILE,0)),^XTMP("LR5XTIME",LRFILE)=$$NOW^LR5XCNV1
 F  S D0=$O(^LRD(65,D0)) Q:'D0  D A1 S D1=0 F  S D1=$O(^LRD(65,D0,2,D1)) Q:'D1  S D2=0 F  S D2=$O(^LRD(65,D0,2,D1,1,D2)) S:'D2 ^XTMP("LR5X",LRFILE,0)=D0 Q:'D2  D A2 W:$D(LRDEBUG) "@",D0
 S $P(^XTMP("LR5XTIME",LRFILE),U,2)=$$NOW^LR5XCNV1
 D OUT
 Q
 ;
A2 ; Change PROVIDER NUMBER field .08, subfile 65.02
 ; sub file of the PATIENT XMATCHED/ASSIGNED subfile
 ;
 S LRSB(0)=2,LRSB(1)=1
 S LRPRV=$P($G(^LRD(65,D0,2,D1,1,D2,0)),U,8) I LRPRV S LRPRV=$$PROV^LR5XCNV0("65.02,.08",LRPRV,.LRSB) S ^LR("TMP",LRFILE)=LRPRV ; testing code
 ; working code S LRPRV=$P($G(^LRD(65,D0,2,D1,1,D2,0)),U,8) I LRPRV S $P(^LRD(65,D0,2,D1,1,D2,0),U,8)=$$PROV^LR5XCNV0("65.02,.08",LRPRV,.LRSB)
 Q
 ;
A1 ; subscript (6) Change PROVIDER NUMBER field 6.6
 S LRPRV=$P($G(^LRD(65,D0,6)),U,6) I LRPRV S ^LR("TMP",LRFILE)=$$PROV^LR5XCNV0("6.6",LRPRV,.LRSB) ;testing code
 ; working code  S LRPRV=$P($G(^LRD(65,D0,6)),U,6) I LRPRV S $P(LRD(65,D0,6),U,6)=$$PROV^LR5XCNV0("6.6",LRPRV,.LRSB)
 Q
 ;
OUT ;
 I $D(LRIO) D REQUE Q
 ;
REENT ; re-entry for reque if LRIO is busy from above
 ;
 D HEAD^LR5XCNV0(LRFILE)
 I '$O(^XTMP("LR5X",LRFILE,0)) W !!?(IOM-$L("****  none found ****"))\2,"**** NONE FOUND ****" G END
 F LRD0=0:0 S LRD0=$O(^XTMP("LR5X",LRFILE,LRD0)) Q:LRD0'>0  F LRD1=0:0 S LRD1=$O(^XTMP("LR5X",LRFILE,LRD0,LRD1)) Q:LRD1'>0  F LRD2=0:0 S LRD2=$O(^XTMP("LR5X",LRFILE,LRD0,LRD1,LRD2)) Q:LRD2'>0  D WRITE
END W @IOF D ^%ZISC K LRD0,LRD1,LRD2,LRFILE,LRFLD,LRTIT,LRVL,ZTSK,LRTSK
 Q
 ;
WRITE ;
 S LRFLD=$O(^XTMP("LR5X",LRFILE,LRD0,LRD1,LRD2,0)),LRVL=$G(^XTMP("LR5X",LRFILE,LRD0,LRD1,LRD2,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(^LRD(65,LRD0,0)),LRD1(0)=$G(^LRD(65,LRD0,2,LRD1,0)),LRD2(0)=$G(^LRD(65,LRD0,2,LRD1,1,LRD2,0))
 I ($Y+10)>IOSL D HEAD^LR5XCNV0(LRFILE)
 W !!!,"The value ("_+LRVL_") """_$P(LRVL,U,2)_""",",!,"in field "_LRTIT_", could not be repointed.",!,"This occurred in:",!,"The BLOOD SAMPLE DATE/TIME: subfile of",?54,"entry: "_$P(LRD2(0),U)
 W !,"The PATIENT XMATCHED/ASSIGNED: subfile of",?54,"entry: "_$P(LRD1(0),U)
 W !,"The BLOOD INVENTORY FILE:",?54,"entry: "_$P(LRD0(0),U)
 Q
 ;
REQUE ; reque task to print out exceptions
 S ZTIO=LRIO,ZTDESC="Requeue of exception report FILE 65 conversion",ZTDTH=$H,ZTRTN="REENT^LR5XCNV5"
 S ZTSAVE("LRFILE")="",ZTSAVE("LRTSK")=""
 D ^%ZTLOAD Q

LR5XCNV8
LR5XCNV8 ; IHS/DIR/FJE - NEW PERSON CONVERSION FOR LAB ^LRO(68 ; 
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
 ;;
 ;
EN ; for entry LRAC must be defined as a valid accession area number
 ;
 Q:'$D(ZTQUEUED)
 N D0,D1,LRACC,LRD1,LREND,LRFLD,LRFILE,LRLST,LRLST2,LRPRV,LRSB,LRTIT,LRTSK
 S LRFILE="LRO-68",(D1,LRLST2)=0,LRTSK=$G(ZTSK)
 ;    at entry LRAC will have a value of one of the accession areas.
 ;    set from the driving routine LR5XCNV.
 ;    ^XTMP("LR5X",LRO-68",LRAC,0)=acc date^acc number of the last full record successfully converted
 ;
 I '$D(^XTMP("LR5X",LRFILE,LRAC,0))#2&(^DD(68,0,"VR")>5.15) Q
EN1 ;
 I '$D(^XTMP("LR5X",LRFILE,LRAC,0))#2 S ^XTMP("LR5X",LRFILE,LRAC,0)=0
 I '$P($G(^XTMP("LR5X",LRFILE,LRAC,0)),U,2) S $P(^XTMP("LR5X",LRFILE,LRAC,0),U,2)=0
 S D1=+$G(^XTMP("LR5X",LRFILE,LRAC,0)),D0=LRAC
 S D2=+$P($G(^XTMP("LR5X",LRFILE,LRAC,0)),U,2)
 S ^XTMP("LR5XTIME",LRFILE,LRAC)=$$NOW^LR5XCNV1
 ;
 ; Change PRACTITIONER field 8, subfile 68.02
 ;
 S LRSB(0)=1,LRSB(1)=1
 F  S LRLST=D1 S D1=$O(^LRO(68,D0,1,D1)) Q:D1'>0  S D2=+D2 F  S D2=$O(^LRO(68,D0,1,D1,1,D2)) Q:D2'>0  D
 . S LRPRV=$P($G(^LRO(68,D0,1,D1,1,D2,0)),U,8),$P(^XTMP("LR5X",LRFILE,LRAC,0),U,2)=D2,$P(^XTMP("LR5X",LRFILE,LRAC,0),U)=D1,LRLST2=D2 I LRPRV D SET
 . ;working codeF  S LRLST=D1,D1=$O(^LRO(68,D0,1,D1)) Q:D1'>0  S D2=+D2 F  S D2=$O(^LRO(68,D0,1,D1,1,D2)) Q:D2'>0  D
 . S LRPRV=$P($G(^LRO(68,D0,1,D1,1,D2,0)),U,8),$P(^XTMP("LR5X",LRFILE,D0,0),U,2)=D2,$P(^XTMP("LR5X",LRFILE,D0,0),U)=D1,LRLST2=D2 I LRPRV D SET
 S ^XTMP("LR5X",LRFILE,LRAC,0)=LRLST_"^"_LRLST2
 S $P(^XTMP("LR5XTIME",LRFILE,LRAC),U,2)=$$NOW^LR5XCNV1
 D OUT
 Q
 ;
SET ;
 S ^LR("TMP",LRFILE,LRAC)=$$PROV^LR5XCNV0("68.02,6.5",LRPRV,.LRSB)
 ; working code S $P(^LRO(68,D0,1,D1,1,D2,0),U,8)=$$PROV^LR5XCNV0("68.02,6.5",LRPRV,.LRSB)
 Q
 ;
OUT ;
 I $D(LRIO) D REQUE Q
 ;
REENT ; re-entry point if LRIO is busy from above
 ;
 S LRACC=$P($G(^LRO(68,LRAC,0)),U)
 D HEAD^LR5XCNV0(LRFILE) W !?(IOM-$L("ACCESSION AREA: "_LRACC))\2,"ACCESSION AREA: "_LRACC
 I '$O(^XTMP("LR5X",LRFILE,LRAC,0)) W !!?(IOM-$L("****  none found ****"))\2,"**** NONE FOUND ****" G END
 S LRD0=LRAC
 F LRD1=0:0 S LRD1=$O(^XTMP("LR5X",LRFILE,LRD0,1,LRD1)) Q:LRD1'>0  F LRD2=0:0 S LRD2=$O(^XTMP("LR5X",LRFILE,LRD0,1,LRD1,1,LRD2)) Q:LRD2'>0  D WRITE
END W @IOF D ^%ZISC
 K LRFILE,LRAC,LRACC,LRD0,LRD1,LRD2,LRFLD,LRTIT,LRTSK
 Q
 ;
WRITE ;
 S LRFLD=$O(^XTMP("LR5X",LRFILE,LRD0,1,LRD1,1,LRD2,0)),LRVL=$G(^XTMP("LR5X",LRFILE,LRD0,1,LRD1,1,LRD2,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(^LRO(68,LRD0,0)),LRD1(0)=$G(^LRO(68,LRD0,1,LRD1,0)),LRD2(0)=$G(^LRO(68,LRD0,1,LRD1,1,LRD2,0))
 I ($Y+10)>IOSL D HEAD^LR5XCNV0(LRFILE)
 W !!!,"The value ("_+LRVL_") """_$P(LRVL,U,2)_""",",!,"in field "_LRTIT_", could not be repointed.",!,"This occurred in:",!,"The ACCESSION NUMBER: subfile of",?54,"entry: `"_LRD2
 W !,"The DATE: subfile of",?54,"entry: "_$P(LRD1(0),U)
 W !,"The ACCESSION FILE:",?54,"entry: "_$P(LRD0(0),U)
 Q
REQUE ; reque task to print out exceptions
 S ZTIO=LRIO,ZTDESC="Requeue of exception report FILE 68 conversion",ZTDTH=$H,ZTRTN="REENT^LR5XCNV8"
 F I="LRAC","LRFILE","LRTSK" S ZTSAVE(I)=""
 D ^%ZTLOAD Q

LR5XCNV9
LR5XCNV9 ; IHS/DIR/FJE - NEW PERSON CONVERSION FOR LAB ^LRO(69... ;
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
 ;;
 ;
EN ;
 ; LRDT must be defined for entry
 Q:'$D(ZTQUEUED)
 N D0,D1,LRD1,LREND,LRFILE,LRFLD,LRLST,LRPRV,LRSB,LRTIT,LRTSK
 S LRFILE="LRO-69",D0=0,LRTSK=$G(ZTSK)
 ;     at entry LRDT will have a value of year only 2910000 in FILEMAN
 ;     format, LREND will ahve a value of LRDT + 9999
 ;     if LRDT=2890000 then LREND=2899999
 ;     ^XTMP("LR5X","LRO-69",LRDT,0) is the last full record successfully converted
 ;
 Q:'LRDT  S LREND=LRDT+9999
 I '$D(^XTMP("LR5X",LRFILE,LRDT,0))#2&(^DD(69,0,"VR")>5.15) Q
EN1 ;
 I '$D(^XTMP("LR5X",LRFILE,LRDT,0))#2 S ^XTMP("LR5X",LRFILE,LRDT,0)=LRDT
 I '$L($P(^XTMP("LR5X",LRFILE,LRDT,0),U,2)) S $P(^XTMP("LR5X",LRFILE,LRDT,0),U,2)=0
 S D0=$G(^XTMP("LR5X",LRFILE,LRDT,0)) Q:D0>(LREND-8650)
 S D1=$P(^XTMP("LR5X",LRFILE,LRDT,0),U,2),^XTMP("LR5XTIME",LRFILE,LRDT)=$$NOW^LR5XCNV1
 F D0=D0:0:LREND S LRLST=D0,D0=+$O(^LRO(69,D0)) Q:D0<1!($E(D0,1,3)>($E(LRDT,1,3)+1))  S D1=+D1,$P(^XTMP("LR5X",LRFILE,LRDT),U)=D0 F  S D1=$O(^LRO(69,D0,1,D1)) Q:'D1  D AN S $P(^XTMP("LR5X",LRFILE,LRDT,0),U,2)=D1
 S ^XTMP("LR5X",LRFILE,LRDT,0)=LRLST_"^"_D1,$P(^XTMP("LR5XTIME",LRFILE,LRDT),U,2)=$$NOW^LR5XCNV1
 D OUT
 Q
 ;
AN ; subscript (0) Change PROVIDER field 7, subfile 69.01
 ; pointer from file 200
 S LRSB(0)=1 W:$D(LRDEBUG) "@",D0
 S LRD1=$G(^LRO(69,D0,1,D1,0)) I LRD1'>0 Q
 S LRPRV=$P(LRD1,U,6) I LRPRV S $P(^LR("TMP",LRFILE,LRDT),U,6)=$$PROV^LR5XCNV0("69.01,7",LRPRV,.LRSB)
 ; working code  S $P(^LRO(69,D0,1,D1,0),U,6)=$$PROV^LR5XCNV0("69.01,7",LRPRV,.LRSB)
 Q
 ;
OUT ;
 I $D(LRIO) D REQUE Q
 ;
REENT ; re-entry for reque if LRIO is busy from above
 D HEAD^LR5XCNV0(LRFILE) W !,?(IOM-$L(LRDT))\2,LRDT
 S NOP=0 F LRD0=LRDT:0:LREND S LRD0=$O(^XTMP("LR5X",LRFILE,LRD0)) Q:LRD0'>0  F LRD1=0:0 S LRD1=$O(^XTMP("LR5X",LRFILE,LRD0,1,LRD1)) Q:LRD1'>0  S NOP=1 D WRITE
 I 'NOP W !!?30,"No Exception to Report",!
 W @IOF D ^%ZISC K LRDT,LREND,ZTSK
 Q
 ;
WRITE ;
 S LRFLD=$O(^XTMP("LR5X",LRFILE,LRD0,1,LRD1,0)),LRVL=$G(^XTMP("LR5X",LRFILE,LRD0,1,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)
 I ($Y+10)>IOSL D HEAD^LR5XCNV0(LRFILE)
 W !!!,"The value ("_+LRVL_") """_$P(LRVL,U,2)_""",",!,"in field "_LRTIT_", could not be repointed.",!,"This occurred in:",!,"The SPECIMEN: subfile of",?54,"entry: `"_LRD1
 W !,"The LAB ORDER ENTRY FILE:",?54,"entry: `"_LRD0
 Q
 ;
REQUE ; reque task to print out exceptions
 S ZTIO=LRIO,ZTDESC="Requeue of exception report FILE 69 conversion",ZTDTH=$H,ZTRTN="REENT^LR5XCNV9"
 F I="LRDT","LRFILE","LREND","LRTSK" S ZTSAVE(I)=""
 D ^%ZTLOAD Q

LR5XCNVA
LR5XCNVA ; IHS/DIR/FJE - NEW PERSON CONVERSION FOR LAB ^LAR("Z" ; 
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jun 20, 1994
 ; From LR5XCNV3
EN ;
 Q:'$D(ZTQUEUED)
 N D0,LRFILE,LRLST,LRPRV,LRTSK
 S LRFILE="LAR-63.9999",D0=0,(LRST,LRJOB)=1,LRTSK=$G(ZTSK)
 ;     ^XTMP("LR5X","LAR-63.9999",0) is the last record converted successfully
 I '$D(^XTMP("LR5X",LRFILE,0))#2&(^DD(63.9999,0,"VR")>5.15) Q
EN1 ;
 I '$D(^XTMP("LR5X",LRFILE,0))#2 S ^XTMP("LR5X",LRFILE,0)=0
 S D0=$G(^XTMP("LR5X",LRFILE,0)),^XTMP("LR5XTIME",LRFILE,LRJOB)=$$NOW^LR5XCNV1
 F  S LRLST=D0,D0=+$O(^LAR("Z",D0)) Q:D0<1  D CH,MI S ^XTMP("LR5X",LRFILE,LRJOB,0)=D0 W:$D(LRDEBUG) "@",D0
 K ZTSK
 S $P(^XTMP("LR5XTIME",LRFILE,LRJOB),U,2)=$$NOW^LR5XCNV1
 D OUT^LR5XCNV4
 Q
CH ; change pointers in CHEM HEM, TOX, RIA, SER, etc. subfile 63.999904
 ; sub("CH") Change REQUESTING PERSON field .1 pointer
 ; ^LAR("Z",LRDFN,"CH",LRIDT,"NPC")=1 Indicates this record has been converted to File 200. This node is used when restoring archive records.
 N LRSB
 S LRSB(0)="CH"
 S D1=0 F  S D1=$O(^LAR("Z",D0,"CH",D1)) Q:'D1  S LRD0=$G(^LAR("Z",D0,"CH",D1,0)),LRPRV=$P(LRD0,U,10) I LRPRV S $P(^LR("TMP",LRFILE,LRJOB),U,10)=$$PROV^LR5XCNV4("63.999904,.1",LRPRV,.LRSB) I LRPRV W:'$D(ZTQUEUED) !,LRPRV
 ;. ;** working code S D1=0 F  S D1=$O(^LAR("Z",D0,"CH",D1)) Q:'D1  S LRD0=$G(^LAR("Z",D0,"CH",D1,0)),LRPRV=$P(LRD0,U,10) D
 ;. I LRPRV S $P(LRD0,U,10)=$$PROV^LR5XCNV4("63.999904,.1",LRPRV,.LRSB) I LRPRV S ^LAR("Z",D0,"CH",D1,0)=LRD0,^LAR("Z",D0,"CH",D1,"NPC")=1
 Q
MI ; change pointers in MICROBIOLOGY subfile 63.999905
 ; sub("MI") Change PHYSICIAN field .07 pointer
 ; ^LAR("Z",LRDFN,"MI",LRIDT,"NPC")=1 Indicates this record has been converted to File 200. This node is used when restoring archive records.
 N LRSB
 S LRSB(0)="MI"
 S D1=0 F  S D1=$O(^LAR("Z",D0,"MI",D1)) Q:'D1  S LRPRV=$P($G(^LAR("Z",D0,"MI",D1,0)),U,7) I LRPRV S $P(^LR("TMP",LRFILE,LRJOB),U,7)=$$PROV^LR5XCNV4("63.999905,.07",LRPRV,.LRSB)
 ;** working codeS D1=0 F  S D1=$O(^LAR("Z",D0,"MI",D1)) Q:'D1  S LRPRV=$P($G(^LAR("Z",D0,"MI",D1,0)),U,7) I LRPRV S $P(^LAR("Z",D0,"MI",D1,0),U,7)=$$PROV^LR5XCNV4("63.999905,.07",LRPRV,.LRSB),^LAR("Z",D0,"MI",D1,"NPC")=1
 Q

LR5XCNVD
LR5XCNVD ; IHS/DIR/FJE - DRIVER FOR THE LAB DATA CONVERSION TO FILE 200 ;
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**128**;Jul 18, 1994
 ;CONTINUATION OF LR5XCNV
DIR1 ;
 K DIR,LRNEWAY S LRALL=0
 S DIR("?")="^D EXPLAIN^LR5XCNVD"
 S DIR("A")="Choose one of the following"
 S DIR(0)="S^1:All tasks at once;2:Throttle through a Device"
 D ^DIR
 I $D(DTOUT)!($D(DUOUT)) S LREND=1 QUIT
 S:Y=2 LRNEWAY=1
 K DIR
 Q
END ;
 K LRIO,LRIO1,LRNEWAY S LREND=0 D ^%ZISC
 Q
EXPLAIN ;
 W !!,"You have the following choices:"
 W !,"1.  Run all tasks at once.  (This procedure is same as Patch 122.) "
 W !,"2.  Name a device to limit the number of tasks to be started."
 W !,"                            OR"
 W !,"3.  Up arrow out and call each file conversion by individual entry point."
 W !,"The entry points are:"
 W !,"D EN63^LR5XCNV",!,"D EN65^LR5XCNV",!,"D EN68^LR5XCNV"
 W !,"D EN69^LR5XCNV",!,"D ENARCH^LR5XCNV"
 W !,"NOTE: You must ensure that ALL ENTRY POINTS HAVE BEEN RUN!!"
 W !,"The Global ^XTMP(""LR5X"", will contain a record of those completed."
 Q

LR5XCNVP
LR5XCNVP ; IHS/DIR/FJE - REPRINT CONVERSION EXCEPTION REPORT ; 
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
EN ;
 S (LREND,LREND0)=0
 F  Q:($D(DUOUT))!($D(DTOUT))!(LREND0)  D
 .D FILE
 .D:'LREND0 TASK
 D WRAPUP
 Q
FILE ;
 W !!
 K DIR S DIR(0)="S^1:63;2:63.9999;3:65;4:68;5:69",DIR("A")="FILE"
 S DIR("?")="Choose which file to use for the reprint"
 D ^DIR
 S LRFILE=$S(Y=1:"LR-63",Y=2:"LAR-63.9999",Y=3:"LRD-65",Y=4:"LRO-68",Y=5:"LRO-69",1:"ERROR")
 S:($D(DUOUT))!($D(DTOUT)) LREND0=1
 Q
TASK ;
 W !
 I (LRFILE="LR-63")!(LRFILE="LAR-63.9999") D
 .D INFO63 Q:(LREND0)!($G(LRST)="")!($G(LRTSK)="")
 .K IOP,IO("Q") S POP=0,%ZIS="QP" D ^%ZIS Q:POP
 .S LRIO=ION
 .I $D(IO("Q")) D REQUE^LR5XCNV4
 .E  U IO D REENT^LR5XCNV4
 E  I LRFILE="LRD-65" D
 .D INFO65 Q:(LREND0)!($G(LRTSK)="")
 .K IOP,IO("Q") S POP=0,%ZIS="QP" D ^%ZIS Q:POP
 .S LRIO=ION
 .I $D(IO("Q")) D REQUE^LR5XCNV5
 .E  U IO D REENT^LR5XCNV5
 E  I LRFILE="LRO-68" D
 .D INFO68 Q:(LREND0)!($G(LRAC)="")!($G(LRTSK)="")
 .K IOP,IO("Q") S POP=0,%ZIS="QP" D ^%ZIS Q:POP
 .S LRIO=ION
 .I $D(IO("Q")) D REQUE^LR5XCNV8
 .E  U IO D REENT^LR5XCNV8
 E  I LRFILE="LRO-69" D
 .D INFO69 Q:(LREND0)!($G(LRDT)="")!($G(LRTSK)="")
 .K IOP,IO("Q") S POP=0,%ZIS="QP" D ^%ZIS Q:POP
 .S LRIO=ION
 .I $D(IO("Q")) D REQUE^LR5XCNV9
 .E  U IO D REENT^LR5XCNV9
 E  D
 .W !!,"ERRONEOUS FILE SELECTED",!
 Q
INFO63 ;
 ;Get task #
 K DIR  S DIR(0)="NO^0:99999999:0"
 S DIR("A")="Enter the TASK # off of the task spawn list"
 S DIR("?",1)="When you started the conversion a list of the tasks being spawned was"
 S DIR("?")="generated.  Each entry shows the Task #.  Enter the Task # now"
 D ^DIR W !!
 S LRTSK=Y Q:LRTSK=""
 I ($D(DTOUT))!($D(DUOUT)) S LREND0=1 Q
 ;Get starting entry #
 K DIR S DIR(0)="NO^0:18000000:0"
 S DIR("A")="Enter the 'from' entry # off of the task spawn list"
 S DIR("?",1)="When you started the conversion a list of the tasks being spawned was"
 S DIR("?",2)="generated.  Each entry shows the Task #.  For each task on file 63 or 63.9999,"
 S DIR("?")="'from' and 'to' entry numbers are given as well.  Enter the from number now^"
 D ^DIR W !!
 S LRST=Y Q:LRST=""
 S LRJOB=(LRST+30000)\30000
 S LRST=((LRJOB-1)*30000)
 S:($D(DTOUT))!($D(DUOUT)) LREND0=1
 Q
INFO65 ;
 ;Get task #
 K DIR  S DIR(0)="NO^0:99999999:0"
 S DIR("A")="Enter the TASK # off of the task spawn list"
 S DIR("?",1)="When you started the conversion a list of the tasks being spawned was"
 S DIR("?")="generated.  Each entry shows the Task #.  Enter the Task # now"
 D ^DIR W !!
 S LRTSK=Y Q:LRTSK=""
 I ($D(DTOUT))!($D(DUOUT)) S LREND0=1 Q
 Q
INFO68 ;
 ;Get task #
 K DIR  S DIR(0)="NO^0:99999999:0"
 S DIR("A")="Enter the TASK # off of the task spawn list"
 S DIR("?",1)="When you started the conversion a list of the tasks being spawned was"
 S DIR("?")="generated.  Each entry shows the Task #.  Enter the Task # now"
 D ^DIR W !!
 S LRTSK=Y Q:LRTSK=""
 I ($D(DTOUT))!($D(DUOUT)) S LREND0=1 Q
 ;Get Accession area #
 K DIR S DIR(0)="FO^1:30"
 S DIR("A")="Enter the (ACCESSION) area # off of the task spawn list"
 S DIR("?",1)="When you started the conversion a list of the tasks being spawned was"
 S DIR("?",2)="generated.  Each entry shows the Task #.  For each task on file 68, an"
 S DIR("?")="(ACCESSION) area # is given as well.  Enter the ACCESSION area # now^"
 D ^DIR W !!
 S LRAC=Y Q:LRAC=""
 I ($D(DTOUT))!($D(DUOUT)) S LREND0=1 Q
 Q
INFO69 ;
 ;Get task #
 K DIR  S DIR(0)="NO^0:99999999:0"
 S DIR("A")="Enter the TASK # off of the task spawn list"
 S DIR("?",1)="When you started the conversion a list of the tasks being spawned was"
 S DIR("?")="generated.  Each entry shows the Task #.  Enter the Task # now"
 D ^DIR W !!
 S LRTSK=Y Q:LRTSK=""
 I ($D(DTOUT))!($D(DUOUT)) S LREND0=1 Q
 ;Get starting year
 K DIR S DIR(0)="DO^::AE^"
 S DIR("A")="Enter the YEAR off of the task spawn list"
 S DIR("?",1)="When you started the conversion a list of the tasks being spawned was"
 S DIR("?",2)="generated.  Each entry shows the Task #.  For each task on file 69, a year"
 S DIR("?")="is given as well.  Enter the YEAR now^"
 D ^DIR W !!
 S LRDT=Y Q:LRDT=""  S LREND=LRDT+9999
 S:($D(DTOUT))!($D(DUOUT)) LREND0=1
 Q
WRAPUP ;
 K DTOUT,DUOUT,DIRUT,DIROUT,X,Y,LRCENT,%ZIS,DIC,LRCENTY,%DT,I,POP,DIR,LRCENTX
 K ZTIO,ZTQUEUED,ZTRTN,ZTSAVE,ZTDESC,ZTSK
 K LREND,LREND0,LRJOB,LRFILE,LRST,LRIO,LRAC,LRDT,LRTSK
 Q

LR5XCNVU
LR5XCNVU ; IHS/DIR/FJE - NEW PERSON CONVERSION FOR LAB ^LR( CONTINUED ;
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
SP ; change pointers in SURGICAL PATHOLOGY subfile 63.08
 ; sub("SP") Change PATHOLOGIST field .02 pointer
 ; sub("SP") Change RESIDENT PATHOLOGIST field .021 pointer
 ; sub("SP") Change SURGEON/PHYSICIAN field .07 pointer
 N LRSB
 S LRSB(0)="SP"
 S D1=0 F  S D1=$O(^LR(D0,"SP",D1)) Q:'D1  S LRFLG=0,LRD0=$G(^LR(D0,"SP",D1,0)) D SP1
 D CY
 Q
 ;
SP1 ;
 S LRPRV=$P(LRD0,U,2) I LRPRV S $P(LRD0,U,2)=$$PROV^LR5XCNV4("63.08,.02",LRPRV,.LRSB),LRFLG=1
 S LRPRV=$P(LRD0,U,4) I LRPRV S $P(LRD0,U,4)=$$PROV^LR5XCNV4("63.08,.021",LRPRV,.LRSB),LRFLG=1
 S LRPRV=$P(LRD0,U,7) I LRPRV S $P(LRD0,U,7)=$$PROV^LR5XCNV4("63.08,.07",LRPRV,.LRSB),LRFLG=1
 I LRFLG S ^LR("TMP",LRFILE,LRJOB)=LRD0
 ; **working code I LRFLG S ^LR(D0,"SP",D1,0)=LRD0
 Q
 ;
 ;
CY ; change pointers in CYTOPATHOLOGY subfile
 ; sub("CY") Change PATHOLOGIST field .02 pointer
 ; sub("CY") Change CYTOTECH field .021 pointer
 ; sub("CY") Change PHYSICIAN field .07 pointer
 N LRSB
 S LRSB(0)="CY"
 S D1=0 F  S D1=$O(^LR(D0,"CY",D1)) Q:'D1  S LRFLG=0,LRD0=$G(^LR(D0,"CY",D1,0)) D CY1
 Q
 ;
CY1 ;
 S LRPRV=$P(LRD0,U,2) I LRPRV S $P(LRD0,U,2)=$$PROV^LR5XCNV4("63.09,.02",LRPRV,.LRSB),LRFLG=1
 S LRPRV=$P(LRD0,U,4) I LRPRV S $P(LRD0,U,4)=$$PROV^LR5XCNV4("63.09,.021",LRPRV,.LRSB),LRFLG=1
 S LRPRV=$P(LRD0,U,7) I LRPRV S $P(LRD0,U,7)=$$PROV^LR5XCNV4("63.09,.07",LRPRV,.LRSB),LRFLG=1
 I LRFLG S ^LR("TMP",LRFILE,LRJOB)=LRD0
 ; **working code I LRFLG S ^LR(D0,"CY",D1,0)=LRD0
 Q

LR5XCNVX
LR5XCNVX ; IHS/DIR/FJE - WKLD (CAP) CODE LIST REPORT PRE INSTALL 5.2 1/16/91 15:34 ;
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
EN ;
 D DT^DICRW D:'$D(IOF) HOME^%ZIS
 I $G(^LAB(60,"PREINIT")) W !?10," I see you already have a list of CAP codes ",!,"from LABORATORY TEST file. ",!!,"Would you like another" S %=2 D YN^DICN G CLEAN:%=2,CLEAN:%<0 D:%=0 HLP I %=0 G EN
 W !!?5,"I will produce a list of CAP codes from your file LABORATORY TEST (#60) "
 K %ZIS S %ZIS="QN",%ZIS("A")="Printer Name " D ^%ZIS G:POP CLEAN
 I IO'=IO(0)!($D(IO("Q"))) S:$D(LRVR) ZTSAVE("LRVR")="" S ZTRTN="QUE^LR5XCNVX",ZTDTH=$H,ZTDESC="PRINT CAP CODES FROM ^LAB(60 " W !!?10,"Report Queued to "_ION,! D ^%ZTLOAD G CLEAN
QUE ;
 K ^TMP($J,"CAP")
 S (LRNAM,LRTS,LRFIRST,LRPG)=0 F  S LRNAM=$O(^LAB(60,"B",LRNAM)) Q:LRNAM=""  F LRTS=0:0 S LRTS=$O(^LAB(60,"B",LRNAM,LRTS)) Q:LRTS<.5  I '$G(^LAB(60,"B",LRNAM,LRTS)) D PRNT
 K DIC,DA,DR
 S I=$O(^TMP($J,"CAP",0)) I $L(I) W @IOF,!!?10,"Alphabetical Listing of All CAP [WKLD] Codes In Use",! S DIC="^LAM(",DR=0,I="" F  S I=$O(^TMP($J,"CAP",I)) Q:I=""  S DA=^TMP($J,"CAP",I) D EN^DIQ
 S ^LAB(60,"PREINIT")=1 G CLEAN
PRNT ;
 I '($D(^LAB(60,LRTS,0))#2) Q
 Q:$P(^LAB(60,LRTS,0),U,3)="N"
 I 'LRFIRST S LRPG=LRPG+1 W @IOF,!!!,?23,"LIST OF CAP [WKLD] CODES",?65,"Pg ",LRPG,!!,"TEST",?15,"CAP Code",?50,"Cap Number",! S LRFIRST=1
 S LRJ=$O(^LAB(60,LRTS,9,0)) Q:LRJ=""
 W !,$P(^LAB(60,LRTS,0),U),!
 D:$D(^LAB(60,LRTS,9,LRJ,0))#2 PCC F LRK=0:0 S LRJ=$O(^LAB(60,LRTS,9,LRJ)) Q:LRJ<1  D:$D(^LAB(60,LRTS,9,LRJ,0))#2 PCC
 Q
PCC ;
 S LRX=^LAB(60,LRTS,9,LRJ,0),LRCC=+LRX G ERR:'$D(^LAM(LRCC,0)) S ^TMP($J,"CAP",$P(^LAM(LRCC,0),U))=LRCC
 W ?10,$S($D(^LAM(LRCC,0))#2:$P(^LAM(LRCC,0),U,1),1:""),?50,$P(LRX,U,2),?73,$S($P(LRX,U,3)=1:"DEF",1:""),! I $Y>(IOSL-6) S LRFIRST=0
 Q
HLP W !!,"During the installation process of V5.2, your CAP entries in the Laboratory Test file will be deleted.",!," A record maybe useful when setting up the files for V 5.2 " Q
ERR W !?10,$C(7)," Error in CAP Code pointer "_LRCC,! Q
CLEAN W @IOF D ^%ZISC K %ZIS,DIFQ,I,LRCC,LRFIRST,LRI,LRJ,LRK,LRTS,LRX,ZTSK,LRCENT,DIC,DA,DR Q

LR5XOK
LR5XOK ; IHS/DIR/FJE - CHECK LAB FILES FOR ODDITIES-DRIVER ; 
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
EN ;
 S (LRENDALL,LRALONE)=0
 K IOP,IO("Q") S POP=0,%ZIS="QP" D ^%ZIS
 I POP S LRENDALL=1
 I $D(IO("Q")) D QUE S LRENDALL=1
 I LRENDALL D WRAPUP Q
DQ ;
 S:$D(ZTQUEUED) ZTREQ="@" K ZTSK U IO
 D:'LRENDALL DQ^LR5XOK3
 D:'LRENDALL DQ^LR5XOKA
 D:'LRENDALL DQ^LR5XOK5
 D:'LRENDALL DQ^LR5XOK8
 D:'LRENDALL DQ^LR5XOK9
 D WRAPUP
 Q
WRAPUP ;
 W @IOF D:'$D(ZTQUEUED) ^%ZISC
 K LRCENT,%ZIS,X,Y,DIR,DTOUT,DUOUT,POP,ZTDESC,ZTRTN,ZTSAVE,ZTSK,ZTIO
 K LRENDALL,LRALONE
 Q
QUE ;
 K IO("Q") I '$D(ZTIO),$D(ION),ION="" S ZTIO=""
 S ZTDESC="LR5XOK - CHECK LAB FILES FOR ODDITIES"
 S ZTRTN="DQ^LR5XOK",ZTSAVE("LR*")=""
 D ^%ZTLOAD
 Q

LR5XOK3
LR5XOK3 ; IHS/DIR/FJE - CHECK LAB DATA FILE (#63) ; 
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
EN ;
 S LREND=0,LRALONE=1
 K IOP,IO("Q") S POP=0,%ZIS="QP" D ^%ZIS
 I POP S LREND=1
 I $D(IO("Q")) D QUE S LREND=1
 I LREND D WRAPUP^LR5XOKU Q
DQ ;
 I LRALONE S:$D(ZTQUEUED) ZTREQ="@" K ZTSK U IO
 S LRDAT=$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),(LRPAG,LREND)=0
 S LRNODS="^0^.091^.092^.1^.2^1^1.5^1.6^1.7^1.8^1.9^2^3^33^80^81^82^83^84^99^AU^AV^AW^AWI^AY^AZC^BB^CH^CY^EM^MI^PG^SP^T^"
 S LRDNODS="^1.6^BB^CH^CY^EM^MI^SP^"
 S LRHDR="^LR( GLOBAL DEFICIENCY REPORT"
 D HDR^LR5XOKU
 D SUB1^LR5XOK31
 D:'LREND SUMMARY^LR5XOKU
 D WRAPUP^LR5XOKU
 Q
QUE ;
 K IO("Q") I '$D(ZTIO),$D(ION),ION="" S ZTIO=""
 S ZTDESC="LR5XOK3 - CHECK LAB DATA FILE FOR ODDITIES"
 S ZTRTN="DQ^LR5XOK3",ZTSAVE("LR*")=""
 D ^%ZTLOAD
 Q

LR5XOK31
LR5XOK31 ; IHS/DIR/FJE - CHECK LAB DATA FILE (#63) ; 
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
EN ;
SUB1 ;
 ;    ***  Entries prior to zero node?  ***
 S LRSUB1="",LREND1=0
 F  S LRSUB1=$O(^LR(LRSUB1)) Q:(LRSUB1'<0)!(LREND1)  D
 . S LREND1=1
 . S LRMSG="Node(s) exist(s) prior to ^LR(0) -- ^LR("_LRSUB1
 . D WRTMSG^LR5XOKU(LRMSG)
 ;    ***  Check 0 node  ***
 S LRSUB1=0
 S LRRC=$G(^LR(LRSUB1))
 I LRRC="" D
 . S LRMSG="Node ^LR(0) is missing"
 . D WRTMSG^LR5XOKU(LRMSG)
 . S LRRC="^^^0"
 ;    ***  Process upto XREFs  ***
 S LRRNUM1=+$P(LRRC,U,4),(LRRCNT1,LRMNY1)=0
 S LRMULT1=$S(LRRNUM1>100:1.3,1:2)
 F  S LRSUB1=$O(^LR(LRSUB1)) Q:(LREND)!(LRSUB1'?1.N)!(LRMNY1)  D
 . ;    ***  Don't run forever/verify record count  ***
 . S LRRCNT1=LRRCNT1+1
 . I LRRNUM1'>0 D
 . . S LRMSG="Record count piece not set/or zero for ^LR(0) but sub-records exists."
 . . D WRTMSG^LR5XOKU(LRMSG)
 . . S LRMNY1=1
 . Q:(LREND)!(LRMNY1)
 . I (LRRCNT1>(LRRNUM1*LRMULT1)) D
 . . S LRMSG="Too many records under ^LR(  -- expected "_LRRNUM1_"  found at least: "_LRRCNT1
 . . D WRTMSG^LR5XOKU(LRMSG)
 . . S LRMNY1=1
 . Q:(LREND)!(LRMNY1)
 . D SUB2
 Q
 ;
SUB2 ;
 ;    ***  Entries prior to zero node?  ***
 S LRSUB2="",LREND2=0
 F  S LRSUB2=$O(^LR(LRSUB1,LRSUB2)) Q:(LREND)!(LRSUB2'<0)!(LREND2)  D
 . S LREND2=1
 . S LRMSG="Node(s) exist(s) under ^LR("_LRSUB1_", prior to ^LR("_LRSUB1_",0) -- ^LR("_LRSUB1_","_LRSUB2
 . D WRTMSG^LR5XOKU(LRMSG)
 Q:LREND
 ;    ***  Check 0 node  ***
 S LRRC=$G(^LR(LRSUB1,0))
 I LRRC="" S LRMSG="Node ^LR("_LRSUB1_",0) is missing" D WRTMSG^LR5XOKU(LRMSG) Q
 ;    ***  From zero node on  ***
 S (LRSUB2,LREND2)=0
 F  S LRSUB2=$O(^LR(LRSUB1,LRSUB2)) Q:(LREND)!(LRSUB2="")  D
 . S LRBADND=0
 . I LRNODS'[(U_LRSUB2_U) D
 . . S LRMSG="Unexpected value in SUB2: ^LR("_LRSUB1_","_LRSUB2
 . . D WRTMSG^LR5XOKU(LRMSG) S LRBADND=1
 . Q:(LREND)!(LRBADND)!(LRSUB2="PG")!(LRSUB2="T")
 . S LRDND=$S(LRDNODS[(U_LRSUB2_U):1,1:0)
 . D SUB3
 . Q:LREND
 Q
SUB3 ;
 ;    ***  Entries prior to zero node?  ***
 S LRSUB3="",LREND3=0
 F  S LRSUB3=$O(^LR(LRSUB1,LRSUB2,LRSUB3)) Q:(LRSUB3'<0)!(LREND3)  D
 . S LREND3=1
 . S LRMSG="Node(s) exist(s) prior to ^LR("_LRSUB1_","_LRSUB2_","_"0) -- ^LR("_LRSUB1_","_LRSUB2_","_LRSUB3
 . D WRTMSG^LR5XOKU(LRMSG)
 Q:LREND
 ;    ***  Check 0 node  ***
 S LRPROBE=$O(^LR(LRSUB1,LRSUB2,0)) Q:LRPROBE=""
 S LRRC=$G(^LR(LRSUB1,LRSUB2,0))
 I LRRC="" D
 . S LRMSG="Node ^LR("_LRSUB1_","_LRSUB2_",0) is missing"
 . D WRTMSG^LR5XOKU(LRMSG)
 . S LRRC="^^^0"
 . S LREND3=1
 Q:(LREND)!(LREND3)
 ;    ***  Process upto XREFs  ***
 S LRRNUM3=+$P(LRRC,U,4),(LRRCNT3,LRMNY3,LRSUB3)=0
 S LRMULT3=$S(LRRNUM3>100:1.3,1:2)
 F  S LRSUB3=$O(^LR(LRSUB1,LRSUB2,LRSUB3)) Q:(LREND)!(LRSUB3'?1N.E)!(LRMNY3)  D
 . S LRDTFLG=0
 . I LRDND D
 . . S (LRDTFLG,LRDTVAL)=0
 . . D CHKDAT^LR5XOKU(9999999-LRSUB3,.LRDTFLG,.LRDTVAL)
 . . I LRDTFLG'>0 D
 . . . S LRMSG="Invalid date:  ^LR("_LRSUB1_","_LRSUB2_","_LRSUB3_"  "_LRDTVAL
 . . . D WRTMSG^LR5XOKU(LRMSG)
 . Q:(LREND)!(LRDTFLG<0)
 . S LRRCNT3=LRRCNT3+1
 . I LRRNUM3'>0 D
 . . S LRMSG="Record count piece not set/or zero for ^LR("_LRSUB1_","_LRSUB2_",0) but sub-records exists."
 . . D WRTMSG^LR5XOKU(LRMSG)
 . . S LRMNY3=1
 . Q:(LREND)!(LRMNY3)
 . I (LRRCNT3>(LRRNUM3*LRMULT3)) D
 . . S LRMSG="Too many sub-records under ^LR("_LRSUB1_","_LRSUB2_",  -- expected: "_LRRNUM3_"  found at least: "_LRRCNT3
 . . D WRTMSG^LR5XOKU(LRMSG)
 . . S LRMNY3=1
 . Q:(LREND)!(LRMNY3)
 . D SUB4
 Q
SUB4 ;
 ;    ***  Entries prior to zero node?  ***
 S LRSUB4="",LREND4=0
 F  S LRSUB4=$O(^LR(LRSUB1,LRSUB2,LRSUB3,LRSUB4)) Q:(LREND)!(LRSUB4'<0)!(LREND4)  D
 . S LREND4=1
 . S LRMSG="Node(s) exist(s) under ^LR("_LRSUB1_","_LRSUB2_","_LRSUB3_", prior to ^LR("_LRSUB1_","_LRSUB2_","_LRSUB3_",0) -- ^LR("_LRSUB1_","_LRSUB2_","_LRSUB3_","_LRSUB4
 . D WRTMSG^LR5XOKU(LRMSG)
 Q:LREND
 ;    ***  Check 0 node  ***
 S LRRC=$G(^LR(LRSUB1,LRSUB2,LRSUB3,0))
 I LRRC="" D
 . S LRMSG="Node ^LR("_LRSUB1_","_LRSUB2_","_LRSUB3_",0) is missing"
 . D WRTMSG^LR5XOKU(LRMSG)
 Q

LR5XOK5
LR5XOK5 ; IHS/DIR/FJE - CHECK LAB BLOOD BANK FILE (#65) ; 
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
EN ;
 S LREND=0,LRALONE=1
 K IOP,IO("Q") S POP=0,%ZIS="QP" D ^%ZIS
 I POP S LREND=1
 I $D(IO("Q")) D QUE S LREND=1
 I LREND D WRAPUP^LR5XOKU Q
DQ ;
 I LRALONE S:$D(ZTQUEUED) ZTREQ="@" K ZTSK U IO
 S LRDAT=$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),(LRPAG,LREND)=0
 S LRHDR="^LRD(65,  GLOBAL DEFICIENCY REPORT"
 D HDR^LR5XOKU
 D SUB1
 D:'LREND SUMMARY^LR5XOKU
 D WRAPUP^LR5XOKU
 Q
SUB1 ;
 ;    ***  Entries prior to zero node?  ***
 S LRSUB1="",(LREND1,LRRCNT1,LRRNUM1)=0
 F  S LRSUB1=$O(^LRD(65,LRSUB1)) Q:(LRSUB1'<0)!(LREND1)  D
 . S LREND1=1
 . S LRMSG="Node(s) exist(s) prior to ^LRD(65,0) -- ^LRD(65,"_LRSUB1
 . D WRTMSG^LR5XOKU(LRMSG)
 ;    ***  Check 0 node  ***
 S LRSUB1=0
 S LRRC=$G(^LRD(65,LRSUB1))
 I LRRC="" D
 . S LRMSG="Node ^LRD(65,0) is missing"
 . D WRTMSG^LR5XOKU(LRMSG)
 . S LRRC="^^^0"
 ;    ***  Process upto XREFs  ***
 S LRRNUM1=+$P(LRRC,U,4),(LRRCNT1,LRMNY1)=0
 S LRMULT1=$S(LRRNUM1>100:1.3,1:2)
 F  S LRSUB1=$O(^LRD(65,LRSUB1)) Q:(LREND)!(LRSUB1'?1N.E)!(LRMNY1)  D
 . ;    ***  Don't run forever/verify record count  ***
 . S LRRCNT1=LRRCNT1+1
 . I LRRNUM1'>0 D
 . . S LRMSG="Record count piece not set/or zero for ^LRD(65,0) but sub-records exists."
 . . D WRTMSG^LR5XOKU(LRMSG)
 . . S LRMNY1=1
 . Q:(LREND)!(LRMNY1)
 . I (LRRCNT1>(LRRNUM1*LRMULT1)) D
 . . S LRMSG="Too many records under ^LRD(65,  -- expected "_LRRNUM1_"  found at least: "_LRRCNT1
 . . D WRTMSG^LR5XOKU(LRMSG)
 . . S LRMNY1=1
 . Q:(LREND)!(LRMNY1)
 . D SUB2
 Q
 ;
SUB2 ;
 ;    ***  Entries prior to zero node?  ***
 S LRSUB2="",LREND2=0
 F  S LRSUB2=$O(^LRD(65,LRSUB1,LRSUB2)) Q:(LREND)!(LRSUB2'<0)!(LREND2)  D
 . S LREND2=1
 . S LRMSG="Node(s) exist(s) under ^LRD(65,"_LRSUB1_", prior to ^LRD(65,"_LRSUB1_",0) -- ^LRD(65,"_LRSUB1_","_LRSUB2
 . D WRTMSG^LR5XOKU(LRMSG)
 Q:LREND
 ;    ***  Check 0 node  ***
 S LRRC=$G(^LRD(65,LRSUB1,0))
 I LRRC="" S LRMSG="Node ^LRD(65,"_LRSUB1_",0) is missing" D WRTMSG^LR5XOKU(LRMSG) Q
 ;    *** From 0 node on  ***
 S (LRSUB2,LREND2)=0
 F  S LRSUB2=$O(^LRD(65,LRSUB1,LRSUB2)) Q:(LREND)!(LRSUB2="")  D SUB3^LR5XOK51
 Q
QUE ;
 K IO("Q") I '$D(ZTIO),$D(ION),ION="" S ZTIO=""
 S ZTDESC="LR5XOK5 - CHECK BLOOD BANK FILE FOR ODDITIES"
 S ZTRTN="DQ^LR5XOK5",ZTSAVE("LR*")=""
 D ^%ZTLOAD
 Q

LR5XOK51
LR5XOK51 ; IHS/DIR/FJE - CHECK LAB BLOOD BANK FILE (#69) ; 
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
EN ;
SUB3 ;
 ;    ***  Entries prior to zero node?  ***
 S LRSUB3="",LREND3=0
 F  S LRSUB3=$O(^LRD(65,LRSUB1,LRSUB2,LRSUB3)) Q:(LRSUB3'<0)!(LREND3)  D
 . S LREND3=1
 . S LRMSG="Node(s) exist(s) prior to ^LRD(65,"_LRSUB1_","_LRSUB2_","_"0) -- ^LRD(65,"_LRSUB1_","_LRSUB2_","_LRSUB3
 . D WRTMSG^LR5XOKU(LRMSG)
 Q:LREND
 ;    ***  Check 0 node  ***
 S LRPROBE=$O(^LRD(65,LRSUB1,LRSUB2,0)) Q:LRPROBE=""
 S LRRC=$G(^LRD(65,LRSUB1,LRSUB2,0))
 I LRRC="" D
 . S LRMSG="Node ^LRD(65,"_LRSUB1_","_LRSUB2_",0) is missing"
 . D WRTMSG^LR5XOKU(LRMSG)
 . S LRRC="^^^0"
 . S LREND3=1
 Q:(LREND)!(LREND3)
 ;    ***  Process upto XREFs  ***
 S LRRNUM3=+$P(LRRC,U,4),(LRRCNT3,LRMNY3,LRSUB3)=0
 S LRMULT3=$S(LRRNUM3>100:1.3,1:2)
 F  S LRSUB3=$O(^LRD(65,LRSUB1,LRSUB2,LRSUB3)) Q:(LREND)!(LRSUB3'?1.N)!(LRMNY3)  D
 . S LRRCNT3=LRRCNT3+1
 . I LRRNUM3'>0 D
 . . S LRMSG="Record count piece not set/or zero for ^LRD(65,"_LRSUB1_","_LRSUB2_",0) but sub-records exists."
 . . D WRTMSG^LR5XOKU(LRMSG)
 . . S LRMNY3=1
 . Q:(LREND)!(LRMNY3)
 . I (LRRCNT3>(LRRNUM3*LRMULT3)) D
 . . S LRMSG="Too many sub-records under ^LRD(65,"_LRSUB1_","_LRSUB2_",  -- expected: "_LRRNUM3_"  found at least: "_LRRCNT3
 . . D WRTMSG^LR5XOKU(LRMSG)
 . . S LRMNY3=1
 . Q:(LREND)!(LRMNY3)
 . D SUB4
 Q
SUB4 ;
 ;    ***  Entries prior to zero node?  ***
 S LRSUB4="",LREND4=0
 F  S LRSUB4=$O(^LRD(65,LRSUB1,LRSUB2,LRSUB3,LRSUB4)) Q:(LREND)!(LRSUB4'<0)!(LREND4)  D
 . S LREND4=1
 . S LRMSG="Node(s) exist(s) under ^LRD(65,"_LRSUB1_","_LRSUB2_","_LRSUB3_", prior to ^LRD(65,"_LRSUB1_","_LRSUB2_","_LRSUB3_",0) -- ^LRD(65,"_LRSUB1_","_LRSUB2_","_LRSUB3_","_LRSUB4
 . D WRTMSG^LR5XOKU(LRMSG)
 Q:LREND
 ;    ***  Check 0 node  ***
 S LRRC=$G(^LRD(65,LRSUB1,LRSUB2,LRSUB3,0))
 I LRRC="" S LRMSG="Node ^LRD(65,"_LRSUB1_","_LRSUB2_","_LRSUB3_",0) is missing" D WRTMSG^LR5XOKU(LRMSG) Q
 ;    *** From 0 node on  ***
 S (LRSUB4,LREND4)=0
 F  S LRSUB4=$O(^LRD(65,LRSUB1,LRSUB4)) Q:(LREND)!(LRSUB4="")  D SUB5
 Q
SUB5 ;
 ;    ***  Entries prior to zero node?  ***
 S LRSUB5="",LREND5=0
 F  S LRSUB5=$O(^LRD(65,LRSUB1,LRSUB2,LRSUB3,LRSUB4,LRSUB5)) Q:(LRSUB5'<0)!(LREND5)  D
 . S LREND5=1
 . S LRMSG="Node(s) exist(s) prior to ^LRD(65,"_LRSUB1_","_LRSUB2_","_"0) -- ^LRD(65,"_LRSUB1_","_LRSUB2_","_LRSUB3_","_LRSUB4_","_LRSUB5
 . D WRTMSG^LR5XOKU(LRMSG)
 Q:LREND
 ;    ***  Check 0 node  ***
 S LRPROBE=$O(^LRD(65,LRSUB1,LRSUB2,LRSUB3,LRSUB4,0)) Q:LRPROBE=""
 S LRRC=$G(^LRD(65,LRSUB1,LRSUB2,LRSUB3,LRSUB4,0))
 I LRRC="" D
 . S LRMSG="Node ^LRD(65,"_LRSUB1_","_LRSUB2_","_LRSUB3_","_LRSUB4_",0) is missing"
 . D WRTMSG^LR5XOKU(LRMSG)
 . S LRRC="^^^0"
 . S LREND5=1
 Q:(LREND)!(LREND5)
 ;    ***  Process upto XREFs  ***
 S LRRNUM5=+$P(LRRC,U,4),(LRRCNT5,LRMNY5,LRSUB5)=0
 S LRMULT5=$S(LRRNUM5>100:1.3,1:2)
 F  S LRSUB5=$O(^LRD(65,LRSUB1,LRSUB2,LRSUB3,LRSUB4,LRSUB5)) Q:(LREND)!(LRSUB5'?1N.E)!(LRMNY5)  D
 . S LRDTFLG=0
 . S (LRDTFLG,LRDTVAL)=0
 . D CHKDAT^LR5XOKU(LRSUB5,.LRDTFLG,.LRDTVAL)
 . I LRDTFLG'>0 D
 . . S LRMSG="Invalid date:  ^LRD(65,"_LRSUB1_","_LRSUB2_","_LRSUB3_","_LRSUB4_","_LRSUB5_"  "_LRDTVAL
 . . D WRTMSG^LR5XOKU(LRMSG)
 . Q:(LREND)!(LRDTFLG<0)
 . S LRRCNT5=LRRCNT5+1
 . I LRRNUM5'>0 D
 . . S LRMSG="Record count piece not set/or zero for ^LRD(65,"_LRSUB1_","_LRSUB2_","_LRSUB3_","_LRSUB4_",0) but sub-records exists."
 . . D WRTMSG^LR5XOKU(LRMSG)
 . . S LRMNY3=1
 . Q:(LREND)!(LRMNY5)
 . I (LRRCNT5>(LRRNUM5*LRMULT5)) D
 . . S LRMSG="Too many sub-records under ^LRD(65,"_LRSUB1_","_LRSUB2_","_LRSUB3_","_LRSUB4_",  -- expected: "_LRRNUM5_"  found at least: "_LRRCNT5
 . . D WRTMSG^LR5XOKU(LRMSG)
 . . S LRMNY5=1
 . Q:(LREND)!(LRMNY5)
 . D SUB6
 Q
SUB6 ;
 ;    ***  Entries prior to zero node?  ***
 S LRSUB6="",LREND6=0
 F  S LRSUB6=$O(^LRD(65,LRSUB1,LRSUB2,LRSUB3,LRSUB4,LRSUB5,LRSUB6)) Q:(LREND)!(LRSUB6'<0)!(LREND6)  D
 . S LREND6=1
 . S LRMSG="Node(s) exist(s) under ^LRD(65,"_LRSUB1_","_LRSUB2_","_LRSUB3_","_LRSUB4_","_LRSUB5_", prior to ^LRD(65,"_LRSUB1_","_LRSUB2_","_LRSUB3_","_LRSUB4_","_LRSUB5
 . S LRMSG=LRMSG_",0) -- ^LRD(65,"_LRSUB1_","_LRSUB2_","_LRSUB3_","_LRSUB4_","_LRSUB5_","_LRSUB6
 . D WRTMSG^LR5XOKU(LRMSG)
 Q:LREND
 ;    ***  Check 0 node  ***
 S LRRC=$G(^LRD(65,LRSUB1,LRSUB2,LRSUB3,LRSUB4,LRSUB5,0))
 I LRRC="" S LRMSG="Node ^LRD(65,"_LRSUB1_","_LRSUB2_","_LRSUB3_","_LRSUB4_","_LRSUB5_",0) is missing" D WRTMSG^LR5XOKU(LRMSG) Q
 Q

LR5XOK8
LR5XOK8 ; IHS/DIR/FJE - CHECK ACCESSION FILE (#68) ; 
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
EN ;
 S LREND=0,LRALONE=1
 K IOP,IO("Q") S POP=0,%ZIS="QP" D ^%ZIS
 I POP S LREND=1
 I $D(IO("Q")) D QUE S LREND=1
 I LREND D WRAPUP^LR5XOKU Q
DQ ;
 I LRALONE S:$D(ZTQUEUED) ZTREQ="@" K ZTSK U IO
 S LRDAT=$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),(LRPAG,LREND)=0
 S LRHDR="^LRO(68,  GLOBAL DEFICIENCY REPORT"
 D HDR^LR5XOKU
 D SUB1
 D:'LREND SUMMARY^LR5XOKU
 D WRAPUP^LR5XOKU
 Q
SUB1 ;
 ;    ***  Entries prior to zero node?  ***
 S (LRSUB1,LRLAST)="",(LREND1,LRRCNT1)=0
 F  S LRSUB1=$O(^LRO(68,LRSUB1)) Q:(LRSUB1'<0)!(LREND1)  D
 . S LREND1=1
 . S LRMSG="Node(s) exist(s) prior to ^LRO(68,0) -- ^LRO(68,"_LRSUB1
 . D WRTMSG^LR5XOKU(LRMSG)
 ;    ***  Check 0 node  ***
 S LRSUB1=0
 S LRRC=$G(^LRO(68,LRSUB1))
 I LRRC="" D
 . S LRMSG="Node ^LRO(68,0) is missing"
 . D WRTMSG^LR5XOKU(LRMSG)
 ;    ***  Process upto XREFs  ***
 F  S LRSUB1=$O(^LRO(68,LRSUB1)) Q:(LREND)!(LRSUB1'?1.N)  D
 . S LRRCNT1=LRRCNT1+1,LRLAST=LRSUB1
 . D SUB2
 S $P(^LRO(68,0),U,3,4)=LRLAST_U_LRRCNT1
 Q
 ;
SUB2 ;
 ;    ***  Entries prior to zero node?  ***
 S LRSUB2="",LREND2=0
 F  S LRSUB2=$O(^LRO(68,LRSUB1,LRSUB2)) Q:(LREND)!(LRSUB2'<0)!(LREND2)  D
 . S LREND2=1
 . S LRMSG="Node(s) exist(s) under ^LRO(68,"_LRSUB1_", prior to ^LRO(68,"_LRSUB1_",0) -- ^LRO(68,"_LRSUB1_","_LRSUB2
 . D WRTMSG^LR5XOKU(LRMSG)
 Q:LREND
 ;    ***  Check 0 node  ***
 S LRRC=$G(^LRO(68,LRSUB1,0))
 I LRRC="" S LRMSG="Node ^LRO(68,"_LRSUB1_",0) is missing" D WRTMSG^LR5XOKU(LRMSG) Q
 S LRSUB2=1
 D SUB3^LR5XOK81
 Q
QUE ;
 K IO("Q") I '$D(ZTIO),$D(ION),ION="" S ZTIO=""
 S ZTDESC="LR5XOK8 - CHECK ACCESSION FILE FOR ODDITIES"
 S ZTRTN="DQ^LR5XOK8",ZTSAVE("LR*")=""
 D ^%ZTLOAD
 Q

LR5XOK81
LR5XOK81 ; IHS/DIR/FJE - CHECK ACCESSION FILE (#68) ; 
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
EN ;
SUB3 ;
 ;    ***  Entries prior to zero node?  ***
 S LRSUB3="",LREND3=0
 F  S LRSUB3=$O(^LRO(68,LRSUB1,LRSUB2,LRSUB3)) Q:(LRSUB3'<0)!(LREND3)  D
 . S LREND3=1
 . S LRMSG="Node(s) exist(s) prior to ^LRO(68,"_LRSUB1_","_LRSUB2_","_"0) -- ^LRO(68,"_LRSUB1_","_LRSUB2_","_LRSUB3
 . D WRTMSG^LR5XOKU(LRMSG)
 Q:LREND
 ;    ***  Check 0 node  ***
 S LRPROBE=$O(^LRO(68,LRSUB1,LRSUB2,0)) Q:LRPROBE=""
 S LRRC=$G(^LRO(68,LRSUB1,LRSUB2,0))
 I LRRC="" D
 . S LRMSG="Node ^LRO(68,"_LRSUB1_","_LRSUB2_",0) is missing"
 . D WRTMSG^LR5XOKU(LRMSG)
 . S LREND3=1
 Q:(LREND)!(LREND3)
 ;    ***  Process upto XREFs  ***
 S LRSUB3=0
 F  S LRSUB3=$O(^LRO(68,LRSUB1,LRSUB2,LRSUB3)) Q:(LREND)!(LRSUB3'?1N.E)  D
 . S LRDTFLG=0
 . S (LRDTFLG,LRDTVAL)=0
 . D CHKDAT^LR5XOKU(LRSUB3,.LRDTFLG,.LRDTVAL)
 . I LRDTFLG'>0 D
 . . S LRMSG="Invalid date:  ^LRO(68,"_LRSUB1_","_LRSUB2_","_LRSUB3_"  "_LRDTVAL
 . . D WRTMSG^LR5XOKU(LRMSG)
 . Q:(LREND)!(LRDTFLG<0)
 . D SUB4
 Q
SUB4 ;
 ;    ***  Entries prior to zero node?  ***
 S LRSUB4="",LREND4=0
 F  S LRSUB4=$O(^LRO(68,LRSUB1,LRSUB2,LRSUB3,LRSUB4)) Q:(LREND)!(LRSUB4'<0)!(LREND4)  D
 . S LREND4=1
 . S LRMSG="Node(s) exist(s) under ^LRO(68,"_LRSUB1_","_LRSUB2_","_LRSUB3_", prior to ^LRO(68,"_LRSUB1_","_LRSUB2_","_LRSUB3_",0) -- ^LRO(68,"_LRSUB1_","_LRSUB2_","_LRSUB3_","_LRSUB4
 . D WRTMSG^LR5XOKU(LRMSG)
 Q:LREND
 ;    ***  Check 0 node  ***
 S LRRC=$G(^LRO(68,LRSUB1,LRSUB2,LRSUB3,0))
 I LRRC="" S LRMSG="Node ^LRO(68,"_LRSUB1_","_LRSUB2_","_LRSUB3_",0) is missing" D WRTMSG^LR5XOKU(LRMSG) Q
 Q

LR5XOK9
LR5XOK9 ; IHS/DIR/FJE - CHECK LAB ORDER ENTRY FILE (#69) ; 
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
EN ;
 S LREND=0,LRALONE=1
 K IOP,IO("Q") S POP=0,%ZIS="QP" D ^%ZIS
 I POP S LREND=1
 I $D(IO("Q")) D QUE S LREND=1
 I LREND D WRAPUP^LR5XOKU Q
DQ ;
 I LRALONE S:$D(ZTQUEUED) ZTREQ="@" K ZTSK U IO
 S LRDAT=$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),(LRPAG,LREND)=0
 S LRHDR="^LRO(69,  GLOBAL DEFICIENCY REPORT"
 D HDR^LR5XOKU
 D SUB1
 D:'LREND SUMMARY^LR5XOKU
 D WRAPUP^LR5XOKU
 Q
SUB1 ;
 ;    ***  Entries prior to zero node?  ***
 S (LRSUB1,LRLAST)="",(LREND1,LRRCNT1)=0
 F  S LRSUB1=$O(^LRO(69,LRSUB1)) Q:(LRSUB1'<0)!(LREND1)  D
 . S LREND1=1
 . S LRMSG="Node(s) exist(s) prior to ^LRO(69,0) -- ^LRO(69,"_LRSUB1
 . D WRTMSG^LR5XOKU(LRMSG)
 ;    ***  Check 0 node  ***
 S LRSUB1=0
 S LRRC=$G(^LRO(69,LRSUB1))
 I LRRC="" D
 . S LRMSG="Node ^LRO(69,0) is missing"
 . D WRTMSG^LR5XOKU(LRMSG)
 ;    ***  Process upto XREFs  ***
 F  S LRSUB1=$O(^LRO(69,LRSUB1)) Q:(LREND)!(LRSUB1'?1N.E)  D
 . S LRRCNT1=LRRCNT1+1,LRLAST=LRSUB1
 . S LRDTFLG=0
 . S (LRDTFLG,LRDTVAL)=0
 . D CHKDAT^LR5XOKU(LRSUB1,.LRDTFLG,.LRDTVAL)
 . I LRDTFLG'>0 D
 . . S LRMSG="Invalid date:  ^LRO(69,"_LRSUB1_"  "_LRDTVAL
 . . D WRTMSG^LR5XOKU(LRMSG)
 . Q:(LREND)!(LRDTFLG<0)
 . D SUB2
 S $P(^LRO(69,0),U,3,4)=LRLAST_U_LRRCNT1
 Q
 ;
SUB2 ;
 ;    ***  Entries prior to zero node?  ***
 S LRSUB2="",LREND2=0
 F  S LRSUB2=$O(^LRO(69,LRSUB1,LRSUB2)) Q:(LREND)!(LRSUB2'<0)!(LREND2)  D
 . S LREND2=1
 . S LRMSG="Node(s) exist(s) under ^LRO(69,"_LRSUB1_", prior to ^LRO(69,"_LRSUB1_",0) -- ^LRO(69,"_LRSUB1_","_LRSUB2
 . D WRTMSG^LR5XOKU(LRMSG)
 Q:LREND
 ;    ***  Check 0 node  ***
 S LRRC=$G(^LRO(69,LRSUB1,0))
 I LRRC="" S LRMSG="Node ^LRO(69,"_LRSUB1_",0) is missing" D WRTMSG^LR5XOKU(LRMSG) Q
 S LRSUB2=1
 D SUB3^LR5XOK91
 Q
QUE ;
 K IO("Q") I '$D(ZTIO),$D(ION),ION="" S ZTIO=""
 S ZTDESC="LR5XOK9 - CHECK LAB ORDER ENTRY FILE FOR ODDITIES"
 S ZTRTN="DQ^LR5XOK9",ZTSAVE("LR*")=""
 D ^%ZTLOAD
 Q

LR5XOK91
LR5XOK91 ; IHS/DIR/FJE - CHECK LAB ORDER ENTRY FILE (#69) ; 
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
EN ;
SUB3 ;
 ;    ***  Entries prior to zero node?  ***
 S LRSUB3="",LREND3=0
 F  S LRSUB3=$O(^LRO(69,LRSUB1,LRSUB2,LRSUB3)) Q:(LRSUB3'<0)!(LREND3)  D
 . S LREND3=1
 . S LRMSG="Node(s) exist(s) prior to ^LRO(69,"_LRSUB1_","_LRSUB2_","_"0) -- ^LRO(69,"_LRSUB1_","_LRSUB2_","_LRSUB3
 . D WRTMSG^LR5XOKU(LRMSG)
 Q:LREND
 ;    ***  Check 0 node  ***
 S LRPROBE=$O(^LRO(69,LRSUB1,LRSUB2,0)) Q:LRPROBE=""
 S LRRC=$G(^LRO(69,LRSUB1,LRSUB2,0))
 I LRRC="" D
 . S LRMSG="Node ^LRO(69,"_LRSUB1_","_LRSUB2_",0) is missing"
 . D WRTMSG^LR5XOKU(LRMSG)
 . S LREND3=1
 Q:(LREND)!(LREND3)
 ;    ***  Process upto XREFs  ***
 S LRSUB3=0
 F  S LRSUB3=$O(^LRO(69,LRSUB1,LRSUB2,LRSUB3)) Q:(LREND)!(LRSUB3'?1N.E)  D
 . D SUB4
 Q
SUB4 ;
 ;    ***  Entries prior to zero node?  ***
 S LRSUB4="",LREND4=0
 F  S LRSUB4=$O(^LRO(69,LRSUB1,LRSUB2,LRSUB3,LRSUB4)) Q:(LREND)!(LRSUB4'<0)!(LREND4)  D
 . S LREND4=1
 . S LRMSG="Node(s) exist(s) under ^LRO(69,"_LRSUB1_","_LRSUB2_","_LRSUB3_", prior to ^LRO(69,"_LRSUB1_","_LRSUB2_","_LRSUB3_",0) -- ^LRO(69,"_LRSUB1_","_LRSUB2_","_LRSUB3_","_LRSUB4
 . D WRTMSG^LR5XOKU(LRMSG)
 Q:LREND
 ;    ***  Check 0 node  ***
 S LRRC=$G(^LRO(69,LRSUB1,LRSUB2,LRSUB3,0))
 I LRRC="" S LRMSG="Node ^LRO(69,"_LRSUB1_","_LRSUB2_","_LRSUB3_",0) is missing" D WRTMSG^LR5XOKU(LRMSG) Q
 S LRSUB4=1
 Q

LR5XOKA
LR5XOKA ; IHS/DIR/FJE - CHECK LAB ARCHIVE DATA FILE (#63.9999) ; 
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
EN ;
 S LREND=0,LRALONE=1
 K IOP,IO("Q") S POP=0,%ZIS="QP" D ^%ZIS
 I POP S LREND=1
 I $D(IO("Q")) D QUE S LREND=1
 I LREND D WRAPUP^LR5XOKU Q
DQ ;
 I LRALONE S:$D(ZTQUEUED) ZTREQ="@" K ZTSK U IO
 S LRDAT=$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),(LRPAG,LREND)=0
 S LRNODS="^0^.091^.092^.1^.2^1^1.5^1.6^1.7^1.8^1.9^2^3^33^80^81^82^83^84^99^AU^AV^AW^AWI^AY^AZC^BB^CH^CY^EM^MI^PG^SP^T^"
 S LRDNODS="^1.6^BB^CH^CY^EM^MI^SP^"
 S LRHDR="^LAR(""Z"", GLOBAL DEFICIENCY REPORT"
 D HDR^LR5XOKU
 D SUB1^LR5XOKA1
 D:'LREND SUMMARY^LR5XOKU
 D WRAPUP^LR5XOKU
 Q
QUE ;
 K IO("Q") I '$D(ZTIO),$D(ION),ION="" S ZTIO=""
 S ZTDESC="LR5XOKA - CHECK LAB ARCHIVE DATA FILE FOR ODDITIES"
 S ZTRTN="DQ^LR5XOKA",ZTSAVE("LR*")=""
 D ^%ZTLOAD
 Q

LR5XOKA1
LR5XOKA1 ; IHS/DIR/FJE - CHECK LAB ARCHIVE DATA FILE (#63.9999) ; 
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
EN ;
SUB1 ;
 ;    ***  Entries prior to zero node?  ***
 S LRSUB1="",LREND1=0
 F  S LRSUB1=$O(^LAR("Z",LRSUB1)) Q:(LRSUB1'<0)!(LREND1)  D
 . S LREND1=1
 . S LRMSG="Node(s) exist(s) prior to ^LAR(""Z"",0) -- ^LAR(""Z"","_LRSUB1
 . D WRTMSG^LR5XOKU(LRMSG)
 ;    ***  Check 0 node  ***
 S LRSUB1=0
 S LRRC=$G(^LAR("Z",LRSUB1))
 I LRRC="" D
 . S LRMSG="Node ^LAR(""Z"",0) is missing"
 . D WRTMSG^LR5XOKU(LRMSG)
 . S LRRC="^^^0"
 ;    ***  Process upto XREFs  ***
 S LRRNUM1=+$P(LRRC,U,4),(LRRCNT1,LRMNY1)=0
 S LRMULT1=$S(LRRNUM1>100:1.3,1:2)
 F  S LRSUB1=$O(^LAR("Z",LRSUB1)) Q:(LREND)!(LRSUB1'?1.N)!(LRMNY1)  D
 . ;    ***  Don't run forever/verify record count  ***
 . S LRRCNT1=LRRCNT1+1
 . I LRRNUM1'>0 D
 . . S LRMSG="Record count piece not set/or zero for ^LAR(""Z"",0) but sub-records exists."
 . . D WRTMSG^LR5XOKU(LRMSG)
 . . S LRMNY1=1
 . Q:(LREND)!(LRMNY1)
 . I (LRRCNT1>(LRRNUM1*LRMULT1)) D
 . . S LRMSG="Too many records under ^LAR(""Z"",  -- expected "_LRRNUM1_"  found at least: "_LRRCNT1
 . . D WRTMSG^LR5XOKU(LRMSG)
 . . S LRMNY1=1
 . Q:(LREND)!(LRMNY1)
 . D SUB2
 Q
 ;
SUB2 ;
 ;    ***  Entries prior to zero node?  ***
 S LRSUB2="",LREND2=0
 F  S LRSUB2=$O(^LAR("Z",LRSUB1,LRSUB2)) Q:(LREND)!(LRSUB2'<0)!(LREND2)  D
 . S LREND2=1
 . S LRMSG="Node(s) exist(s) under ^LAR(""Z"","_LRSUB1_", prior to ^LAR(""Z"","_LRSUB1_",0) -- ^LAR(""Z"","_LRSUB1_","_LRSUB2
 . D WRTMSG^LR5XOKU(LRMSG)
 Q:LREND
 ;    ***  Check 0 node  ***
 S LRRC=$G(^LAR("Z",LRSUB1,0))
 I LRRC="" S LRMSG="Node ^LAR(""Z"","_LRSUB1_",0) is missing" D WRTMSG^LR5XOKU(LRMSG) Q
 ;    ***  From zero node on  ***
 S (LRSUB2,LREND2)=0
 F  S LRSUB2=$O(^LAR("Z",LRSUB1,LRSUB2)) Q:(LREND)!(LRSUB2="")  D
 . S LRBADND=0
 . I LRNODS'[(U_LRSUB2_U) D
 . . S LRMSG="Unexpected value in SUB2: ^LAR(""Z"","_LRSUB1_","_LRSUB2
 . . D WRTMSG^LR5XOKU(LRMSG) S LRBADND=1
 . Q:(LREND)!(LRBADND)!(LRSUB2="PG")!(LRSUB2="T")
 . S LRDND=$S(LRDNODS[(U_LRSUB2_U):1,1:0)
 . I LRSUB2="AU" D
 . . S LRRC=$G(^LAR("Z",LRSUB1,LRSUB2))
 . . I LRRC="" D
 . . . S LRMSG="Missing node -- ^LAR(""Z"","_LRSUB1_","_LRSUB2_")"
 . . . D WRTMSG^LR5XOKU(LRMSG)
 . . . S LREND2=1
 . . Q:LREND2
 . . S LREND2=1
 . Q:LREND2
 . D SUB3
 . Q:LREND
 Q
SUB3 ;
 ;    ***  Process upto XREFs  ***
 S LRSUB3=0
 F  S LRSUB3=$O(^LAR("Z",LRSUB1,LRSUB2,LRSUB3)) Q:(LREND)!(LRSUB3'?1N.E)  D
 . S LRDTFLG=0
 . I LRDND D
 . . S (LRDTFLG,LRDTVAL)=0
 . . D CHKDAT^LR5XOKU(9999999-LRSUB3,.LRDTFLG,.LRDTVAL)
 . . I LRDTFLG'>0 D
 . . . S LRMSG="Invalid date:  ^LAR(""Z"","_LRSUB1_","_LRSUB2_","_LRSUB3_"  "_LRDTVAL
 . . . D WRTMSG^LR5XOKU(LRMSG)
 . Q:(LREND)!(LRDTFLG<0)
 . D SUB4
 Q
SUB4 ;
 ;    ***  Entries prior to zero node?  ***
 S LRSUB4="",LREND4=0
 F  S LRSUB4=$O(^LAR("Z",LRSUB1,LRSUB2,LRSUB3,LRSUB4)) Q:(LREND)!(LRSUB4'<0)!(LREND4)  D
 . S LREND4=1
 . S LRMSG="Node(s) exist(s) under ^LAR(""Z"","_LRSUB1_","_LRSUB2_","_LRSUB3_", prior to ^LAR(""Z"","_LRSUB1_","_LRSUB2_","_LRSUB3_",0) -- ^LAR(""Z"","_LRSUB1_","_LRSUB2_","_LRSUB3_","_LRSUB4
 . D WRTMSG^LR5XOKU(LRMSG)
 Q:LREND
 ;    ***  Check 0 node  ***
 S LRRC=$G(^LAR("Z",LRSUB1,LRSUB2,LRSUB3,0))
 I LRRC="" D
 . S LRMSG="Node ^LAR(""Z"","_LRSUB1_","_LRSUB2_","_LRSUB3_",0) is missing"
 . D WRTMSG^LR5XOKU(LRMSG)
 Q
 ;

LR5XOKU
LR5XOKU ; IHS/DIR/FJE - CHECK LAB FILES FOR ODDITIES-UTILITIES ; 
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
CHKDAT(LRDT,LRDOK,LRVAL) ;
 ;LRDOK>0  --  Date field in valid range
 ;LRDOK=0  --  Not a date variable
 ;LRDOK<0  --  Date field not in valid range
 D NOW^%DTC S X1=X,X2=420 D C^%DTC S LRCKA=X
 S %DT="T",X=LRDT
 D ^%DT
 I Y=-1 S LRDOK=0,LRVAL=""
 E  D
 . I Y<2850000 S LRDOK=-1,LRVAL=Y_"  too far in past" Q
 . I Y>LRCKA S LRDOK=-1,LRVAL=Y_"  too far in future" Q
 . S LRDOK=1,LRVAL=""
 Q
 ;
WRTMSG(LRMSG) ;
 W !,LRMSG
 I ($Y>(IOSL-6)) D:$E(IOST,1,2)="C-" PAUSE Q:LREND  W @IOF D HDR
 Q
PAUSE ;
 K DIR S DIR(0)="E" D ^DIR
 S:($D(DTOUT)#2)!($D(DUOUT)#2)!($D(DIRUT)#2) LREND=1
 Q
HDR ;
 S LRPAG=LRPAG+1 F I=1:1:80 W "-"
 W !,LRHDR
 W ?62,LRDAT,?72,"PAGE ",$J(LRPAG,3)
 W ! F I=1:1:80 W "-"
 Q
SUMMARY ;
 I ($Y>(IOSL-9)) D:$E(IOST,1,2)="C-" PAUSE Q:LREND  W @IOF D HDR
 W !!,"There were ",LRRCNT1," records found. "
 F I=$Y:1:(IOSL-6) W !
 W !!?23,"***  END OF REPORT  ***"
 Q
WRAPUP ;
 D:($E(IOST,1,2)="C-")&('LREND) PAUSE
 S:LREND LRENDALL=1
 W @IOF
 I LRALONE K LRALONE,LRENDALL D:'$D(ZTQUEUED) ^%ZISC
 K LREND,LRDTFLG,LRRC,LRDAT,LRBADND,LRDNODS,LRHDR,LRNODS,LRDND,LRLAST
 K LRMSG,LROK,LRPAG,LRPROBE,LRDTVAL,LRMULT1,LRMULT3,LRMULT5
 K LREND1,LRRCNT1,LRMNY1,LRSUB1,LRRNUM1
 K LREND3,LRRCNT3,LRMNY3,LRSUB3,LRRNUM3
 K LREND5,LRRCNT5,LRMNY5,LRSUB5,LRRNUM5
 K LREND2,LRSUB2,LREND4,LRSUB4,LREND6,LRSUB6
 K I,X,Y,LRCENT,%DT,%ZIS,POP,DIRUT,DTOUT,DUOUT
 K ZTDESC,ZTIO,ZTQUEUED,ZTRTN,ZTSAV
 Q

LR5XTIM2
LR5XTIM2 ; IHS/DIR/FJE - CONVERSION TIMES REPORT ; 
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
EN ;
LR5X ;
 Q:'$D(^XTMP("LR5XTIME"))
 S (LR5X63T,LR5XOTHT,LR5XEND)=0,(LR5X63N,LR5XOTHN)="",LR5XBEG=9999999
 S LRHDR="LAB TIMES FOR ^XTMP(""LR5XTIME"") NODES"
 D HDR
 S LRPTR="^XTMP(""LR5XTIME"")"
 F  S LRPTR=$Q(@LRPTR) Q:(LREND)!(LRPTR'["XTMP(""LR5XTIME""")  D
 . S LRVAL=@LRPTR
 . ;Find diff. to the minute
 . S (LRFROM,X2)=$P(LRVAL,U),(LRTO,X1)=$P(LRVAL,U,2),X3=2
 . S:X2<LR5XBEG LR5XBEG=X2
 . S:X1>LR5XEND LR5XEND=X1
 . S LRTIME=$$DTC^LR5XCNV1(X1,X2,X3)
 . S LRFRDT=$P(LRFROM,"."),LRFRTM=$E($P(LRFROM,".",2)_"0000",1,4)
 . S LRFRDT=$E(LRFRDT,4,5)_"/"_$E(LRFRDT,6,7)_"/"_$E(LRFRDT,2,3)
 . S LRTODT=$P(LRTO,"."),LRTOTM=$E($P(LRTO,".",2)_"0000",1,4)
 . S LRTODT=$E(LRTODT,4,5)_"/"_$E(LRTODT,6,7)_"/"_$E(LRTODT,2,3)
 . S LRVAL=LRFRDT_" @"_LRFRTM_"  "_LRTODT_" @"_LRTOTM
 . I LRPTR["LR-63" D
 . . S:LRTIME>LR5X63T LR5X63T=LRTIME,LR5X63N=LRPTR_"="_LRVAL
 . E  D
 . . S:LRTIME>LR5XOTHT LR5XOTHT=LRTIME,LR5XOTHN=LRPTR_"="_LRVAL
 . I ($Y>(IOSL-6)) D:$E(IOST,1,2)="C-" PAUSE Q:LREND  W @IOF D HDR
 . Q:LREND
 . S LRPRINT="^XTMP("_$P(LRPTR,"XTMP(",2)
 . W !,$J($J(LRTIME,6,4),11),?13,LRPRINT,?50,LRVAL
 Q:LREND
 D:$E(IOST,1,2)="C-" PAUSE
 Q
LR52 ;
 Q:'$D(^XTMP("LR52TIME"))
 S (LR5263T,LR52OTHT,LR52END)=0,(LR5263N,LR52OTHN)="",LR52BEG=9999999
 S LRHDR="LAB TIMES FOR ^XTMP(""LR52TIME"") NODES"
 W @IOF D HDR
 S LRPTR="^XTMP(""LR52TIME"")"
 F  S LRPTR=$Q(@LRPTR) Q:(LREND)!(LRPTR'["XTMP(""LR52TIME""")  D
 . S LRVAL=@LRPTR
 . ;Find diff. to the minute
 . S (LRFROM,X2)=$P(LRVAL,U),(LRTO,X1)=$P(LRVAL,U,2),X3=2
 . S:X2<LR52BEG LR52BEG=X2
 . S:X1>LR52END LR52END=X1
 . S LRTIME=$$DTC^LR5XCNV1(X1,X2,X3)
 . S LRFRDT=$P(LRFROM,"."),LRFRTM=$E($P(LRFROM,".",2)_"0000",1,4)
 . S LRFRDT=$E(LRFRDT,4,5)_"/"_$E(LRFRDT,6,7)_"/"_$E(LRFRDT,2,3)
 . S LRTODT=$P(LRTO,"."),LRTOTM=$E($P(LRTO,".",2)_"0000",1,4)
 . S LRTODT=$E(LRTODT,4,5)_"/"_$E(LRTODT,6,7)_"/"_$E(LRTODT,2,3)
 . S LRVAL=LRFRDT_" @"_LRFRTM_"  "_LRTODT_" @"_LRTOTM
 . I LRPTR["LR-63" D
 . . S:LRTIME>LR5263T LR5263T=LRTIME,LR5263N=LRPTR_"="_LRVAL
 . E  D
 . . S:LRTIME>LR52OTHT LR52OTHT=LRTIME,LR52OTHN=LRPTR_"="_LRVAL
 . I ($Y>(IOSL-6)) D:$E(IOST,1,2)="C-" PAUSE Q:LREND  W @IOF D HDR
 . Q:LREND
 . S LRPRINT="^XTMP("_$P(LRPTR,"XTMP(",2)
 . W !,$J($J(LRTIME,6,4),11),?13,LRPRINT,?50,LRVAL
 Q:LREND
 D:$E(IOST,1,2)="C-" PAUSE
 Q
HDR ;
 S LRPAG=LRPAG+1 F I=1:1:80 W "-"
 W !,LRHDR,?62,LRDAT,?72,"PAGE ",$J(LRPAG,3)
 W !?2,"TIME DIFF"
 W !,"  DAYS.HHMM",?13,"NODE NAME",?50,"STARTED",?65,"STOPPED"
 W ! F I=1:1:80 W "-"
 Q
PAUSE ;
 K DIR S DIR(0)="E" D ^DIR
 S:($D(DTOUT)#2)!($D(DUOUT)#2)!($D(DIRUT)#2) LREND=1
 Q

LR5XTIME
LR5XTIME ; IHS/DIR/FJE - CONVERSION TIMES REPORT ; 
 ;;5.1;LR;**05**;NOV 01, 1997
 ;
 ;;5.1;LAB SERVICE;**122,128**;Jul 18, 1994
EN ;
 D:'$D(U) DT^DICRW
 S LREND=0
DEVICE ;
 K IOP,IO("Q") S POP=0,%ZIS="QP" D ^%ZIS
 I POP S LREND=1 G WRAPUP
 I $D(IO("Q")) D QUE S LREND=1 G WRAPUP
DQ ;
 D INIT
 D PROCESS
 D WRAPUP
 Q
INIT ;
 S:$D(ZTQUEUED) ZTREQ="@" K ZTSK U IO
 S LRDAT=$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),(LRPAG,LREND)=0
 Q
PROCESS ;
 W:$E(IOST,1,2)="C-" @IOF
 D LR5X^LR5XTIM2 Q:LREND
 D LR52^LR5XTIM2 Q:LREND
 D LASTPAG
 Q
LASTPAG ;
 Q:('$D(^XTMP("LR52TIME")))&('$D(^XTMP("LR5XTIME")))
 W @IOF
 S LRHDR="GREATEST TIME DIFFERENCES"
 D HDR
 ;*********************************
 ;  PREDICTED CONVERSION TIMES
 ;*********************************
 I $D(^XTMP("LR5XTIME")) D
 . W !!!!
 . S X1=LR5XEND,X2=LR5XBEG,X3=2
 . S LRTIME=$$DTC^LR5XCNV1(X1,X2,X3)
 . S LR5XPTIM=($P(LRTIME,".")*24*60)+($E($P(LRTIME,".",2),1,2)*60)+($E($P(LRTIME,".",2),3,4))
 . S LR5XPTIM=$P((LR5XPTIM*1.4+.5),".")
 . S LR5XPMIN=LR5XPTIM#60,LR5XPHR=LR5XPTIM\60,LR5XPDAY=LR5XPHR\24,LR5XPHR=LR5XPHR#24
 . S LR5XPTIM=$E("00"_1,(2-$L(LR5XPDAY)))_LR5XPDAY_"."_$E("00"_1,(2-$L(LR5XPHR)))_LR5XPHR_$E("00"_1,(2-$L(LR5XPMIN)))_LR5XPMIN
 . W !,"LR5XTIME - TOTAL TIME:  "_LRTIME
 . W !!!
 . W !,"LR5XTIME -- 'LR-63' greatest time difference:"
 . W !,"---------------------------------------------"
 . W !,$J($J(LR5X63T,6,4),11),?13
 . W "^XTMP("_$P($P(LR5X63N,"="),"XTMP(",2),?50,$P(LR5X63N,"=",2)
 . W !!
 . W !,"LR5XTIME -- 'other' greatest time difference:"
 . W !,"---------------------------------------------"
 . W !,$J($J(LR5XOTHT,6,4),11),?13
 . W "^XTMP("_$P($P(LR5XOTHN,"="),"XTMP(",2),?50,$P(LR5XOTHN,"=",2)
 . W !!
 . W !,"PROJECTED TIME FOR ACTUAL CONVERSION:"
 . W !,"-------------------------------------"
 . W !,$J($J(LR5XPTIM,6,4),11)
 ;*********************************
 ;  ACTUAL CONVERSION TIMES
 ;*********************************
 I $D(^XTMP("LR52TIME")) D
 . W !!!!
 . S X1=LR52END,X2=LR52BEG,X3=2
 . S LRTIME=$$DTC^LR5XCNV1(X1,X2,X3)
 . W !,"LR52TIME - TOTAL TIME:  "_LRTIME
 . W !!!
 . W !,"LR52TIME -- 'LR-63' greatest time difference:"
 . W !,"---------------------------------------------"
 . W !,$J($J(LR5263T,6,4),11),?13
 . W "^XTMP("_$P($P(LR5263N,"="),"XTMP(",2),?50,$P(LR5263N,"=",2)
 . W !!
 . W !,"LR52TIME -- 'other' greatest time difference:"
 . W !,"---------------------------------------------"
 . W !,$J($J(LR52OTHT,6,4),11),?13
 . W "^XTMP("_$P($P(LR52OTHN,"="),"XTMP(",2),?50,$P(LR52OTHN,"=",2)
 W !!?23,"***  END OF REPORT  ***"
 Q
HDR ;
 S LRPAG=LRPAG+1 F I=1:1:80 W "-"
 W !,LRHDR,?62,LRDAT,?72,"PAGE ",$J(LRPAG,3)
 W !?2,"TIME DIFF"
 W !,"  DAYS.HHMM",?13,"NODE NAME",?50,"STARTED",?65,"STOPPED"
 W ! F I=1:1:80 W "-"
 Q
PAUSE ;
 K DIR S DIR(0)="E" D ^DIR
 S:($D(DTOUT)#2)!($D(DUOUT)#2)!($D(DIRUT)#2) LREND=1
 Q
WRAPUP ;
 D:($E(IOST,1,2)="C-")&('LREND) PAUSE
 W @IOF D:'$D(ZTQUEUED) ^%ZISC
 K DTOUT,DUOUT,DIRUT,DIROUT,X,Y,LRCENT,%ZIS,DIC,LRCENTY,LRCENTT,%DT,I,POP,DIR
 K ZTIO,ZTQUEUED,ZTRTN,ZTSAVE,ZTDESC,AGE,DOB,SEX,LR5XPTIM,LRPRINT
 K LREND,LRPAG,LRDT,LRMDT,LRMDAT,LRSITSEL,LR52BEG,LR52END,LR5XBEG,LR5XEND
 K X1,X2,X3,LRPTR,LRVAL,LRTIME,LRDAT,LRHDR,LR5XPDAY,LR5XPHR,LR5XPMIN
 K LR5X63T,LR5X63N,LR5263T,LR5263N,LR5XOTHT,LR5XOTHN,LR52OTHT,LR52OTHN
 K LRFROM,LRFRDT,LRFRTM,LRTO,LRTODT,LRTOTM
 Q
QUE ;
 K IO("Q") I '$D(ZTIO),$D(ION),ION="" S ZTIO=""
 S ZTDESC="LR5XTIME - LAB CONV. TIMES REPORT",ZTRTN="DQ^LR5XTIME"
 S ZTSAVE("LR*")="" D ^%ZTLOAD
 Q