- LRCAPBV ;VA/DALOI/FHS - PROCESS VBECS WORKLOAD API ; 13-Aug-2013 09:15 ; MKK
- ;;5.2;LAB SERVICE;**325,1031,401,1033**;NOV 1, 1997
- ;
- ;Reference to $$FIND1^DIC supported by IA #2051
- ;Reference to FILE^DID supported by IA #2052
- ;Reference to FILE^DIE supported by IA #2053
- ;Reference to GETS^DIQ supported by IA #2056
- ;Reference to $$GET^XUA4A72 supported by IA #1625
- ;Reference to $$WKLDCAP^VBECA7 supported by IA #4767
- ;Reference to UPDTWKLD^VBECA7 supported by IA #4767
- EN ;Will only run if VBECS BUNDLE 1.0 is installed.
- Q:'($D(^VBEC(6002.01,0)))
- BBLOOK ;
- LOCK L +^XTMP("BVEC WKLD"):10 G:'$T LOCK
- Q:$G(^XTMP("BVEC WKLD",0))=+$H S ^XTMP("BVEC WKLD",0)=+$H
- N ANS,ANX
- N D1,D2,DFN,ERR,FILE,IEN,LRAA,LRACC,LRADT,LRAN,LRACPABV,LRCC
- N LRCDT,LRCNT,LRCTM,LRD65,LRDAA,LRDFN,LRDIV,LRDLOC,LRDPRO,LRDSUF
- N LRE655,LREDT,LRERR,LRESCPT,LRFDA,LRFILE,LRFNUM,LRIDT
- N LRII,LRIN,LRLD,LRLOG,LRLSS,LRMA,LRNLT,LROA,LROAD,LROAD1,LROAD2
- N LROL,LRPKG,LRREC,LRRRL,LRRRL1,LRRRL3,LRRRL4,LRSUF,LRTEC,LRTS
- N LRTST,LRTSTP,LRTYPE,LRUG,LRUID,LRUNIT,LRWA,LRWKLAA,LRZCNT,X,Y
- N LRCAPBV,LRDPF,LRNP,LRUA,LRRRL2,LRSN,LRSPEC,LRSTATUS,LRVSITN
- N LRTSTU,LRTSQA,LRTSTD
- GET ;Call VBECS 6002.01 data populating API
- S ANS=$$WKLDCAP^VBECA7
- G:ANS'=1 END
- S LRCAPBV=1,LRESCPT=0
- DLOC ;Get default location and provider
- D GETS^DIQ(69.9,"1,",".8;617","I","ANS","ERR")
- S LRDLOC=$G(ANS(69.9,"1,",.8,"I"))
- S LRDPRO=$G(ANS(69.9,"1,",617,"I"))
- I $$GET^XUA4A72(LRDPRO)<1 G END
- S:'$G(LRIEN) LRIEN=0
- LK1 ;Set default values
- S LRPKG=$$FIND1^DIC(9.4,"","O","LAB SERVICE","B","","ANS")
- I LRPKG<1 S ERR=9.4
- S LRDAA=$$FIND1^DIC(68,"","O","BLOOD BANK","B","","ANS")
- S:'LRDAA LRDAA=29
- S LRD65=$$FIND1^DIC(65,"","B","VBECS1","B","","ANS")
- S LRDSUF=$$FIND1^DIC(64.2,"","O","GENERIC","B","","ANS")
- I '$G(LRD65) S LRSTATUS="LRD(65 missing",LRERR="Failed lookup" D G END
- . S ERR=65 D EUPDATE
- TST ;Get default tests names
- S LRTSTQA=$$FIND1^DIC(60,,"B","VBEC QA/QC","B",,"ANS")
- S LRTSTU=$$FIND1^DIC(60,,"B","VBEC UNIT PROCESSING","B",,"ANS")
- S LRTSTD=$$FIND1^DIC(60,,"B","VBEC DONOR","B",,"ANS")
- I $S('LRTSTQA:1,'LRTSTU:1,'LRTSTD:1,1:0) D G END
- . S ERR=$S('LRTSTQA:"VBEC QA/QC ",'LRTSTU:"VBEC UNIT PROCESSING",1:"VBEC DONOR") D EUPDATE
- Q:$G(LRDBUG)
- DPROV ;Set default PCE Provider
- LOOP ;Find entries with the status of pending.
- F S LRIEN=$O(^VBEC(6002.01,"AC","P",LRIEN)) Q:LRIEN<1 D BBDIQ
- Q:$G(LRDBUG)
- I $D(ZTQUEUED) S ZTREQ="@"
- END ;
- L -^XTMP("BVEC WKLD")
- ;Call VBECS update API
- D UPDTWKLD^VBECA7
- K LRIEN
- Q
- BBDIQ ;Gather entry info
- I $G(LRDBUG) W !,LRIEN
- K ANS,ANX,ERR,FILE,LRFDA
- K ^VBEC(6002.01,LRIEN,"ERR")
- S FILE=6002.01,IEN=LRIEN_","
- D GETS^DIQ(FILE,IEN,"**","IN","ANS","ERR")
- D ERR Q:$G(ERR)
- S LRFDA(6002.01,LRIEN_",",5)="I"
- D FILE^DIE("S","LRFDA","ERR")
- D LRAA
- Q:$G(ERR)
- S:$G(LRWKLAA) (LRMA,LRWA,LRLSS)=LRWKLAA
- S LRCDT=$P(ANS(6002.01,LRIEN_",",3,"I"),".")
- S LRCTM=$P(ANS(6002.01,LRIEN_",",3,"I"),".",2)
- D ^LRCAPV3
- K LRFDA S LRFDA(6002.01,LRIEN_",",5)="S"
- S LRFDA(6002.01,LRIEN_",",4)=$$NOW^XLFDT
- D FILE^DIE("S","LRFDA","ERR")
- PCEFILE ;File PCE if outpatient location
- Q:$S(LRRRL4="W":0,LRRRL4="O":0,1:1)
- I $G(DFN) D
- . D EN^LRCAPBV1(LRADT,LRTEC,LRTST,LRDSSLOC,LRDSSID,LRIN,DFN,LRPRO,LRCNT)
- Q
- ERR ;Check entry for critical data
- I $G(ERR) S LRERR="Failed lookup",LRSTATUS="E" D EUPDATE Q
- D INIT^LRCAPBB S LRLD="CP"
- S ERR=0
- TYPE S LRTYPE=$G(ANS(6002.01,IEN,1,"I")) D Q:$G(ERR)
- . I '$L(LRTYPE) S ERR=1 D EUPDATE
- DIV S LRDIV=+$G(ANS(6002.01,IEN,2,"I")) D Q:$G(ERR)
- . I '$D(^DIC(4,+LRDIV,0)) S ERR=2 D EUPDATE
- . S LRIN=LRDIV
- ADT S (LRADT,LREDT)=$G(ANS(6002.01,IEN,3,"I")) D Q:$G(ERR)
- . I LRADT'?7N1"."1N.E S ERR=3 D EUPDATE
- . S LRCDT=$P(LRADT,"."),LRCTM=$P(LRADT,".",2)
- NLT S LRNLT=$G(ANS(6002.01,IEN,6,"I")) D Q:$G(ERR)
- . I '$D(^LAM(LRNLT,0)) S ERR=6 D EUPDATE
- SUF S LRSUF=$G(ANS(6002.01,IEN,7,"I")) D Q:$G(ERR)
- . S:'LRSUF LRSUF=LRDSUF
- . S LRCC=$$NLT^LRCAPBV1(LRNLT,LRSUF) ;Lookup or create NLT code
- . D GETS^DIQ(64.2,LRSUF_",",1,"I","ANS","ERR")
- . S LRSUF=$P($G(ANS(64.2,LRSUF_",",1,"I")),".",2)
- S LRCNT=$G(ANS(6002.01,IEN,8,"I")) I 'LRCNT S LRCNT=1
- DFN S DFN=$G(ANS(6002.01,IEN,9,"I")) D I $G(ERR) D EUPDATE Q
- . S LRDFN=""
- . Q:LRTYPE'="P"
- . S LRDFN=$G(^DPT(+DFN,"LR"))
- . ;I 'LRDFN S ERR=9 ;RLM 6/12/08 This isn't always an error and the data is evaluated in VBECS prior to transmission
- FILE I LRTYPE="U"!(LRTYPE="M") S LRFILE=LRD65_";LRD(65,"
- I LRTYPE="D" S LRFILE=LRE655_";LRE("
- I LRTYPE="P" S LRFILE=DFN_";DPT("
- TEC S LRTEC=$G(ANS(6002.01,IEN,10,"I")) D Q:$G(ERR)
- . I '$D(^VA(200,LRTEC,0)) S ERR=10 D EUPDATE
- S LRAA=$S($G(LRDAA):LRDAA,1:29),LRAN=""
- UID S LRUID=$G(ANS(6002.01,IEN,11,"I")) D Q:$G(ERR)
- . I '$L(LRUID) Q
- . S LRAA=+$O(^LRO(68,"C",LRUID,0)) Q:LRAA<1
- . S LRCDT=$O(^LRO(68,"C",LRUID,LRAA,0))
- . S LRAN=$O(^LRO(68,"C",LRUID,LRAA,LRCDT,0))
- . S ERR=$S('LRAA:11,'LRAA:11,'LRAN:11,'$D(^LRO(68,LRAA,1,LRCDT,1,LRAN,0)):11,1:0)
- . I ERR D EUPDATE
- TS K LRTS,LRTST,LRTSTP S LRTS=0
- I $G(ANS(6002.01,IEN,12,"I")) S (LRTS,LRTST,LRTSTP)=+$G(ANS(6002.01,IEN,12,"I"))
- I 'LRTS D
- . I LRTYPE="U" S (LRTS,LRTST,LRTSTP)=LRTSTU
- . I LRTYPE="M" S (LRTS,LRTST,LRTSTP)=LRTSTQA
- . I LRTYPE="D" S (LRTS,LRTST,LRTSTP)=LRTSTD
- ; I 'LRTS,$G(LRAA),$G(LRCDT),$G(LRAN) S (LRTS,LRTST,LRTSTP)=$O(^LRO(68,LRAA,1,LRCDT,1,LRAN,4,0))
- D Q:$G(ERR)
- . S ERR=0
- . ;I '$D(^LAB(60,LRTS,0)) S ERR=12 D EUPDATE ;;RLM 6/12/08 This isn't always an error and the data is evaluated in VBECS prior to transmission
- UNIT S LRUNIT=$G(ANS(6002.01,IEN,13,"I")) D Q:ERR
- . I LRTYPE="U" S LRFILE=LRD65_";LRD(65," I '$L(LRUNIT) S ERR=13 D EUPDATE
- LRDAA S LRWKLAA=$G(ANS(6002.01,IEN,14,"I"))
- Q
- EUPDATE ;Set error codes into entry
- I $D(LRDBUG) W !,ERR
- K LRFDA(1)
- S:'$G(LRIEN) LRIEN=$O(^VBEC(6002.01,0))
- S LRFDA(1,6002.01,LRIEN_",",5)="E"
- I $G(ERR) S LRFDA(1,6002.01,LRIEN_",",20)="Field "_ERR_" has an error"
- I '$G(ERR) S LRFDA(1,6002.01,LRIEN_",",20)=ERR_" Error"
- D FILE^DIE("S","LRFDA(1)","ERRX")
- Q
- LRAA ;Get accession data
- S LRAA=$G(ANS(6002.01,LRIEN_",",14,"I"))
- S LRAA=$S($G(LRAA):LRAA,1:LRDAA)
- K ANX,ERX
- D GETS^DIQ(68,LRAA_",",.19,"I","ANX","ERR")
- S LRLD=$G(ANX(68,LRAA_",",.19,"I"))
- AA ;Accession Area Information
- S (LRMA,LRWA,LRLSS)=LRAA,LRUG=9
- I $G(LRAN),$G(LRCDT),$G(LRAA) D
- . Q:'$D(^LRO(68,LRAA,1,LRCDT,1,LRAN,0))
- . S IEN=LRAN_","_LRCDT_","_LRAA_","
- . D GETS^DIQ(68,LRAA_",",.8,"I","ANX","ERX")
- . S LRDSSLOC=$G(ANX(68,LRAA_",",.8,"I"))
- . S:'LRDSSLOC LRDSSLOC=LRDLOC
- . D GETS^DIQ(44,LRDSSLOC_",",8,"I","ANX","ERX")
- . S LRDSSID=$G(ANX(44,LRDSSLOC_",",8,"I"))
- . S FLD=".01;.02;2;3;4;6;6.5;6.6;6.7;15;92;94"
- . D GETS^DIQ(68.02,IEN,FLD,"IN","ANX","ERX")
- . D GETS^DIQ(68.05,1_","_IEN,.01,"IN","ANX","ERX")
- . D GETS^DIQ(68.04,LRTS_","_IEN,1,"IN","ANX","ERX")
- LRAA1 . ;Parse variables
- . S LRFILE=$P($G(^LRO(68,LRAA,1,LRCDT,1,LRAN,0)),U,2)
- . S LRDFN=$G(ANX(68.02,IEN,.01,"I"))
- . D GETS^DIQ(63,LRDFN_",",".02;.03","I","ANX","ERX")
- DPF . S LRDPF=$G(ANX(63,LRDFN_",",.02,"I"))
- . S DFN=$G(ANX(63,LRDFN_",",.03,"I"))
- . D FILE^DID(LRFILE,"","GLOBAL NAME","ANX","ERX")
- . I $G(LRDFN),$G(DFN) S LRFILE=DFN_";"_$P(ANX("GLOBAL NAME"),U,2)
- ACCES . S LROAD=$G(ANX(68.02,IEN,2,"I"))
- . S LROAD1=$G(ANX(68.02,IEN,3,"I"))
- . S (LRSN,LROAD2)=$G(ANX(68.02,IEN,4,"I"))
- . S LRSPEC=$G(ANX(68.05,1_","_IEN,.01,"I"))
- . S LRRRL=$G(ANX(68.02,IEN,6,"I"))
- . S (LRPRO,LRRRL1)=$G(ANX(68.02,IEN,6.5,"I"))
- . S LRRRL3=$G(ANX(68.02,IEN,6.7,"I"))
- . S LRACC=$G(ANX(68.02,IEN,15,"I"))
- . S LROL=$G(ANX(68.02,IEN,94,"I"))
- . D GETS^DIQ(44,LROL_",","2;9.5","IN","ANX","ERX")
- . S LRRRL2=$G(ANX(44,LROL_",",9.5,"I"))
- . S LRRRL4=$G(ANX(44,LROL_",",2,"I"))
- . S LRIDT=""
- URG . S LRUG=$G(ANX(68.04,LRTS_","_IEN,1,"I"))
- Q
- LRCAPBV ;VA/DALOI/FHS - PROCESS VBECS WORKLOAD API ; 13-Aug-2013 09:15 ; MKK
- +1 ;;5.2;LAB SERVICE;**325,1031,401,1033**;NOV 1, 1997
- +2 ;
- +3 ;Reference to $$FIND1^DIC supported by IA #2051
- +4 ;Reference to FILE^DID supported by IA #2052
- +5 ;Reference to FILE^DIE supported by IA #2053
- +6 ;Reference to GETS^DIQ supported by IA #2056
- +7 ;Reference to $$GET^XUA4A72 supported by IA #1625
- +8 ;Reference to $$WKLDCAP^VBECA7 supported by IA #4767
- +9 ;Reference to UPDTWKLD^VBECA7 supported by IA #4767
- EN ;Will only run if VBECS BUNDLE 1.0 is installed.
- +1 IF '($DATA(^VBEC(6002.01,0)))
- QUIT
- BBLOOK ;
- LOCK LOCK +^XTMP("BVEC WKLD"):10
- IF '$TEST
- GOTO LOCK
- +1 IF $GET(^XTMP("BVEC WKLD",0))=+$HOROLOG
- QUIT
- SET ^XTMP("BVEC WKLD",0)=+$HOROLOG
- +2 NEW ANS,ANX
- +3 NEW D1,D2,DFN,ERR,FILE,IEN,LRAA,LRACC,LRADT,LRAN,LRACPABV,LRCC
- +4 NEW LRCDT,LRCNT,LRCTM,LRD65,LRDAA,LRDFN,LRDIV,LRDLOC,LRDPRO,LRDSUF
- +5 NEW LRE655,LREDT,LRERR,LRESCPT,LRFDA,LRFILE,LRFNUM,LRIDT
- +6 NEW LRII,LRIN,LRLD,LRLOG,LRLSS,LRMA,LRNLT,LROA,LROAD,LROAD1,LROAD2
- +7 NEW LROL,LRPKG,LRREC,LRRRL,LRRRL1,LRRRL3,LRRRL4,LRSUF,LRTEC,LRTS
- +8 NEW LRTST,LRTSTP,LRTYPE,LRUG,LRUID,LRUNIT,LRWA,LRWKLAA,LRZCNT,X,Y
- +9 NEW LRCAPBV,LRDPF,LRNP,LRUA,LRRRL2,LRSN,LRSPEC,LRSTATUS,LRVSITN
- +10 NEW LRTSTU,LRTSQA,LRTSTD
- GET ;Call VBECS 6002.01 data populating API
- +1 SET ANS=$$WKLDCAP^VBECA7
- +2 IF ANS'=1
- GOTO END
- +3 SET LRCAPBV=1
- SET LRESCPT=0
- DLOC ;Get default location and provider
- +1 DO GETS^DIQ(69.9,"1,",".8;617","I","ANS","ERR")
- +2 SET LRDLOC=$GET(ANS(69.9,"1,",.8,"I"))
- +3 SET LRDPRO=$GET(ANS(69.9,"1,",617,"I"))
- +4 IF $$GET^XUA4A72(LRDPRO)<1
- GOTO END
- +5 IF '$GET(LRIEN)
- SET LRIEN=0
- LK1 ;Set default values
- +1 SET LRPKG=$$FIND1^DIC(9.4,"","O","LAB SERVICE","B","","ANS")
- +2 IF LRPKG<1
- SET ERR=9.4
- +3 SET LRDAA=$$FIND1^DIC(68,"","O","BLOOD BANK","B","","ANS")
- +4 IF 'LRDAA
- SET LRDAA=29
- +5 SET LRD65=$$FIND1^DIC(65,"","B","VBECS1","B","","ANS")
- +6 SET LRDSUF=$$FIND1^DIC(64.2,"","O","GENERIC","B","","ANS")
- +7 IF '$GET(LRD65)
- SET LRSTATUS="LRD(65 missing"
- SET LRERR="Failed lookup"
- Begin DoDot:1
- +8 SET ERR=65
- DO EUPDATE
- End DoDot:1
- GOTO END
- TST ;Get default tests names
- +1 SET LRTSTQA=$$FIND1^DIC(60,,"B","VBEC QA/QC","B",,"ANS")
- +2 SET LRTSTU=$$FIND1^DIC(60,,"B","VBEC UNIT PROCESSING","B",,"ANS")
- +3 SET LRTSTD=$$FIND1^DIC(60,,"B","VBEC DONOR","B",,"ANS")
- +4 IF $SELECT('LRTSTQA:1,'LRTSTU:1,'LRTSTD:1,1:0)
- Begin DoDot:1
- +5 SET ERR=$SELECT('LRTSTQA:"VBEC QA/QC ",'LRTSTU:"VBEC UNIT PROCESSING",1:"VBEC DONOR")
- DO EUPDATE
- End DoDot:1
- GOTO END
- +6 IF $GET(LRDBUG)
- QUIT
- DPROV ;Set default PCE Provider
- LOOP ;Find entries with the status of pending.
- +1 FOR
- SET LRIEN=$ORDER(^VBEC(6002.01,"AC","P",LRIEN))
- IF LRIEN<1
- QUIT
- DO BBDIQ
- +2 IF $GET(LRDBUG)
- QUIT
- +3 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- END ;
- +1 LOCK -^XTMP("BVEC WKLD")
- +2 ;Call VBECS update API
- +3 DO UPDTWKLD^VBECA7
- +4 KILL LRIEN
- +5 QUIT
- BBDIQ ;Gather entry info
- +1 IF $GET(LRDBUG)
- WRITE !,LRIEN
- +2 KILL ANS,ANX,ERR,FILE,LRFDA
- +3 KILL ^VBEC(6002.01,LRIEN,"ERR")
- +4 SET FILE=6002.01
- SET IEN=LRIEN_","
- +5 DO GETS^DIQ(FILE,IEN,"**","IN","ANS","ERR")
- +6 DO ERR
- IF $GET(ERR)
- QUIT
- +7 SET LRFDA(6002.01,LRIEN_",",5)="I"
- +8 DO FILE^DIE("S","LRFDA","ERR")
- +9 DO LRAA
- +10 IF $GET(ERR)
- QUIT
- +11 IF $GET(LRWKLAA)
- SET (LRMA,LRWA,LRLSS)=LRWKLAA
- +12 SET LRCDT=$PIECE(ANS(6002.01,LRIEN_",",3,"I"),".")
- +13 SET LRCTM=$PIECE(ANS(6002.01,LRIEN_",",3,"I"),".",2)
- +14 DO ^LRCAPV3
- +15 KILL LRFDA
- SET LRFDA(6002.01,LRIEN_",",5)="S"
- +16 SET LRFDA(6002.01,LRIEN_",",4)=$$NOW^XLFDT
- +17 DO FILE^DIE("S","LRFDA","ERR")
- PCEFILE ;File PCE if outpatient location
- +1 IF $SELECT(LRRRL4="W"
- QUIT
- +2 IF $GET(DFN)
- Begin DoDot:1
- +3 DO EN^LRCAPBV1(LRADT,LRTEC,LRTST,LRDSSLOC,LRDSSID,LRIN,DFN,LRPRO,LRCNT)
- End DoDot:1
- +4 QUIT
- ERR ;Check entry for critical data
- +1 IF $GET(ERR)
- SET LRERR="Failed lookup"
- SET LRSTATUS="E"
- DO EUPDATE
- QUIT
- +2 DO INIT^LRCAPBB
- SET LRLD="CP"
- +3 SET ERR=0
- TYPE SET LRTYPE=$GET(ANS(6002.01,IEN,1,"I"))
- Begin DoDot:1
- +1 IF '$LENGTH(LRTYPE)
- SET ERR=1
- DO EUPDATE
- End DoDot:1
- IF $GET(ERR)
- QUIT
- DIV SET LRDIV=+$GET(ANS(6002.01,IEN,2,"I"))
- Begin DoDot:1
- +1 IF '$DATA(^DIC(4,+LRDIV,0))
- SET ERR=2
- DO EUPDATE
- +2 SET LRIN=LRDIV
- End DoDot:1
- IF $GET(ERR)
- QUIT
- ADT SET (LRADT,LREDT)=$GET(ANS(6002.01,IEN,3,"I"))
- Begin DoDot:1
- +1 IF LRADT'?7N1"."1N.E
- SET ERR=3
- DO EUPDATE
- +2 SET LRCDT=$PIECE(LRADT,".")
- SET LRCTM=$PIECE(LRADT,".",2)
- End DoDot:1
- IF $GET(ERR)
- QUIT
- NLT SET LRNLT=$GET(ANS(6002.01,IEN,6,"I"))
- Begin DoDot:1
- +1 IF '$DATA(^LAM(LRNLT,0))
- SET ERR=6
- DO EUPDATE
- End DoDot:1
- IF $GET(ERR)
- QUIT
- SUF SET LRSUF=$GET(ANS(6002.01,IEN,7,"I"))
- Begin DoDot:1
- +1 IF 'LRSUF
- SET LRSUF=LRDSUF
- +2 ;Lookup or create NLT code
- SET LRCC=$$NLT^LRCAPBV1(LRNLT,LRSUF)
- +3 DO GETS^DIQ(64.2,LRSUF_",",1,"I","ANS","ERR")
- +4 SET LRSUF=$PIECE($GET(ANS(64.2,LRSUF_",",1,"I")),".",2)
- End DoDot:1
- IF $GET(ERR)
- QUIT
- +5 SET LRCNT=$GET(ANS(6002.01,IEN,8,"I"))
- IF 'LRCNT
- SET LRCNT=1
- DFN SET DFN=$GET(ANS(6002.01,IEN,9,"I"))
- Begin DoDot:1
- +1 SET LRDFN=""
- +2 IF LRTYPE'="P"
- QUIT
- +3 SET LRDFN=$GET(^DPT(+DFN,"LR"))
- +4 ;I 'LRDFN S ERR=9 ;RLM 6/12/08 This isn't always an error and the data is evaluated in VBECS prior to transmission
- End DoDot:1
- IF $GET(ERR)
- DO EUPDATE
- QUIT
- FILE IF LRTYPE="U"!(LRTYPE="M")
- SET LRFILE=LRD65_";LRD(65,"
- +1 IF LRTYPE="D"
- SET LRFILE=LRE655_";LRE("
- +2 IF LRTYPE="P"
- SET LRFILE=DFN_";DPT("
- TEC SET LRTEC=$GET(ANS(6002.01,IEN,10,"I"))
- Begin DoDot:1
- +1 IF '$DATA(^VA(200,LRTEC,0))
- SET ERR=10
- DO EUPDATE
- End DoDot:1
- IF $GET(ERR)
- QUIT
- +2 SET LRAA=$SELECT($GET(LRDAA):LRDAA,1:29)
- SET LRAN=""
- UID SET LRUID=$GET(ANS(6002.01,IEN,11,"I"))
- Begin DoDot:1
- +1 IF '$LENGTH(LRUID)
- QUIT
- +2 SET LRAA=+$ORDER(^LRO(68,"C",LRUID,0))
- IF LRAA<1
- QUIT
- +3 SET LRCDT=$ORDER(^LRO(68,"C",LRUID,LRAA,0))
- +4 SET LRAN=$ORDER(^LRO(68,"C",LRUID,LRAA,LRCDT,0))
- +5 SET ERR=$SELECT('LRAA:11,'LRAA:11,'LRAN:11,'$DATA(^LRO(68,LRAA,1,LRCDT,1,LRAN,0)):11,1:0)
- +6 IF ERR
- DO EUPDATE
- End DoDot:1
- IF $GET(ERR)
- QUIT
- TS KILL LRTS,LRTST,LRTSTP
- SET LRTS=0
- +1 IF $GET(ANS(6002.01,IEN,12,"I"))
- SET (LRTS,LRTST,LRTSTP)=+$GET(ANS(6002.01,IEN,12,"I"))
- +2 IF 'LRTS
- Begin DoDot:1
- +3 IF LRTYPE="U"
- SET (LRTS,LRTST,LRTSTP)=LRTSTU
- +4 IF LRTYPE="M"
- SET (LRTS,LRTST,LRTSTP)=LRTSTQA
- +5 IF LRTYPE="D"
- SET (LRTS,LRTST,LRTSTP)=LRTSTD
- End DoDot:1
- +6 ; I 'LRTS,$G(LRAA),$G(LRCDT),$G(LRAN) S (LRTS,LRTST,LRTSTP)=$O(^LRO(68,LRAA,1,LRCDT,1,LRAN,4,0))
- +7 Begin DoDot:1
- +8 SET ERR=0
- +9 ;I '$D(^LAB(60,LRTS,0)) S ERR=12 D EUPDATE ;;RLM 6/12/08 This isn't always an error and the data is evaluated in VBECS prior to transmission
- End DoDot:1
- IF $GET(ERR)
- QUIT
- UNIT SET LRUNIT=$GET(ANS(6002.01,IEN,13,"I"))
- Begin DoDot:1
- +1 IF LRTYPE="U"
- SET LRFILE=LRD65_";LRD(65,"
- IF '$LENGTH(LRUNIT)
- SET ERR=13
- DO EUPDATE
- End DoDot:1
- IF ERR
- QUIT
- LRDAA SET LRWKLAA=$GET(ANS(6002.01,IEN,14,"I"))
- +1 QUIT
- EUPDATE ;Set error codes into entry
- +1 IF $DATA(LRDBUG)
- WRITE !,ERR
- +2 KILL LRFDA(1)
- +3 IF '$GET(LRIEN)
- SET LRIEN=$ORDER(^VBEC(6002.01,0))
- +4 SET LRFDA(1,6002.01,LRIEN_",",5)="E"
- +5 IF $GET(ERR)
- SET LRFDA(1,6002.01,LRIEN_",",20)="Field "_ERR_" has an error"
- +6 IF '$GET(ERR)
- SET LRFDA(1,6002.01,LRIEN_",",20)=ERR_" Error"
- +7 DO FILE^DIE("S","LRFDA(1)","ERRX")
- +8 QUIT
- LRAA ;Get accession data
- +1 SET LRAA=$GET(ANS(6002.01,LRIEN_",",14,"I"))
- +2 SET LRAA=$SELECT($GET(LRAA):LRAA,1:LRDAA)
- +3 KILL ANX,ERX
- +4 DO GETS^DIQ(68,LRAA_",",.19,"I","ANX","ERR")
- +5 SET LRLD=$GET(ANX(68,LRAA_",",.19,"I"))
- AA ;Accession Area Information
- +1 SET (LRMA,LRWA,LRLSS)=LRAA
- SET LRUG=9
- +2 IF $GET(LRAN)
- IF $GET(LRCDT)
- IF $GET(LRAA)
- Begin DoDot:1
- +3 IF '$DATA(^LRO(68,LRAA,1,LRCDT,1,LRAN,0))
- QUIT
- +4 SET IEN=LRAN_","_LRCDT_","_LRAA_","
- +5 DO GETS^DIQ(68,LRAA_",",.8,"I","ANX","ERX")
- +6 SET LRDSSLOC=$GET(ANX(68,LRAA_",",.8,"I"))
- +7 IF 'LRDSSLOC
- SET LRDSSLOC=LRDLOC
- +8 DO GETS^DIQ(44,LRDSSLOC_",",8,"I","ANX","ERX")
- +9 SET LRDSSID=$GET(ANX(44,LRDSSLOC_",",8,"I"))
- +10 SET FLD=".01;.02;2;3;4;6;6.5;6.6;6.7;15;92;94"
- +11 DO GETS^DIQ(68.02,IEN,FLD,"IN","ANX","ERX")
- +12 DO GETS^DIQ(68.05,1_","_IEN,.01,"IN","ANX","ERX")
- +13 DO GETS^DIQ(68.04,LRTS_","_IEN,1,"IN","ANX","ERX")
- LRAA1 ;Parse variables
- +1 SET LRFILE=$PIECE($GET(^LRO(68,LRAA,1,LRCDT,1,LRAN,0)),U,2)
- +2 SET LRDFN=$GET(ANX(68.02,IEN,.01,"I"))
- +3 DO GETS^DIQ(63,LRDFN_",",".02;.03","I","ANX","ERX")
- DPF SET LRDPF=$GET(ANX(63,LRDFN_",",.02,"I"))
- +1 SET DFN=$GET(ANX(63,LRDFN_",",.03,"I"))
- +2 DO FILE^DID(LRFILE,"","GLOBAL NAME","ANX","ERX")
- +3 IF $GET(LRDFN)
- IF $GET(DFN)
- SET LRFILE=DFN_";"_$PIECE(ANX("GLOBAL NAME"),U,2)
- ACCES SET LROAD=$GET(ANX(68.02,IEN,2,"I"))
- +1 SET LROAD1=$GET(ANX(68.02,IEN,3,"I"))
- +2 SET (LRSN,LROAD2)=$GET(ANX(68.02,IEN,4,"I"))
- +3 SET LRSPEC=$GET(ANX(68.05,1_","_IEN,.01,"I"))
- +4 SET LRRRL=$GET(ANX(68.02,IEN,6,"I"))
- +5 SET (LRPRO,LRRRL1)=$GET(ANX(68.02,IEN,6.5,"I"))
- +6 SET LRRRL3=$GET(ANX(68.02,IEN,6.7,"I"))
- +7 SET LRACC=$GET(ANX(68.02,IEN,15,"I"))
- +8 SET LROL=$GET(ANX(68.02,IEN,94,"I"))
- +9 DO GETS^DIQ(44,LROL_",","2;9.5","IN","ANX","ERX")
- +10 SET LRRRL2=$GET(ANX(44,LROL_",",9.5,"I"))
- +11 SET LRRRL4=$GET(ANX(44,LROL_",",2,"I"))
- +12 SET LRIDT=""
- URG SET LRUG=$GET(ANX(68.04,LRTS_","_IEN,1,"I"))
- End DoDot:1
- +1 QUIT
