- BLRAG01 ; IHS/MSC/SAT - LABORATORY ACCESSION GUI RPCS ;
- ;;5.2;IHS LABORATORY;**1031**;NOV 01, 1997;Build 185
- ;
- ; BLR REF LAB USING LEDI - UL^BLRAG02 = return the value of the 'REF LAB USING LEDI?' field in the BLR MASTER CONTROL file
- ; BLR ICD LOOKUP - ICDLKUP^BLRAG07 = ICD code lookup
- ; BLR ORDER REASON LKUP - ORL^BLRAG07 = return order reasons from file 100.03
- ; BLR PATIENT LOOKUP - PTLK^BLRAG04 = Patient Lookup
- ; BLR PRINTERS AVAILABLE - DEVICE^BLRAG10 = return available printers from the DEVICE file
- ; BLR USER LOOKUP - NP^BLRAG06 = return entries from the NEW PERSON table 200 that are 'active'
- ;
- ; BLR ACCESSION - ACC^BLRAG05 = lab accession processor
- ; BLR ACCESSION PRINT - ABR^BLRAG02 = reprint accession label or manifest
- ; BLR ALL NON-ACCESSIONED - ANA^BLRAG01 = return all non-accessioned lab records
- ; BLR ALL-ACCESSIONED - ABD^BLRAG02 = return all accessioned records for given date range
- ; BLR COLLECTION INFO - BLC^BLRAG06 = check BLR PT CONFIRM parameter and return insurances for patient
- ; BLR DELETE TEST - DELTST^BLRAG08 = Cancel tests - Test are no longer deleted, instead the status is changed to Not Performed.
- ; BLR ORDER/TEST STATUS - LROS^BLRAG03 = return order/test status for given patient and date range
- ;
- ; BLR SHIP CONF - SC^BLRAG09A = select a shipping configuration
- ; BLR MANIFEST BUILD - BM^BLRAG09B = build a shipping manifest
- ; BLR MANIFEST CLOSE/SHIP - CLSHIP^BLRAG09C = Close/ship a shipping manifest
- ; BLR MANIFEST DISPLAY - DISP^BLRAG09G = screen formatted text for manifest display
- ; BLR MANIFEST START - SMONLY^BLRAG09C = Start a shipping manifest only, no building
- ; BLR MANIFEST TEST ADD - ADDTEST^BLRAG09C= Add tests to an existing manifest
- ; BLR MANIFEST TEST REMOVE - REMVTST^BLRAG09C= Remove a test from manifest - actually flags test as "removed".
- ; BLR MANIFEST TESTS TO ADD- TARPC^BLRAG09B = return tests that can be added to a manifest
- ;
- ;return all non-accessioned lab records - RPC
- ANA(BLRY,BLRDFN,BLRUSRDY) ;return appointment data for given patient - RPC
- ; RPC Name is BLR ALL NON-ACCESSIONED
- ;INPUT:
- ; .BLRY = returned pointer to appointment data
- ; BLRDFN = (optional) return all non-accessioned lab records for this
- ; given patient only
- ; return for all patients of this parameter
- ; is not defined
- ; BLRUSRDY = Temporary User Override of the BLR DAYS TO ACCESSION XPAR Parameter
- ;
- ;RETURNS:
- ; (0) DFN
- ; (1) PNAME
- ; (2) HRN
- ; (3) DOB
- ; (5) IFN
- ; (6) Grp
- ; (7) ActTm
- ; (8) StrtTm
- ; (9) StopTm
- ; (10) Sts
- ; (11) Sig
- ; (12) Nrs
- ; (13) Clk
- ; (14) PrvID
- ; (15) PrvNam
- ; (16) ActDA
- ; (17) Flag
- ; (18) DCType
- ; (19) ChrtRev
- ; (20) DEA#
- ; (21) <NOT USED>
- ; (22) SCHEDULE
- ; (23) ORDER_TEXT
- ; (24) DETAIL_TEXT
- ; (25) STREET_LINE1
- ; (26) STREET_LINE2
- ; (27) STREET_LINE3
- ; (28) CITY
- ; (29) STATE
- ; (30) ZIP
- ; (31) SEX
- ; (32) COLLECTION_TYPE
- ; (33) DATE_TIME_ORDERED
- ; (34) LAB_ORDER_#
- ; (35) TEST_NAME
- ; (36) COLLECTION_SAMPLE
- ; (37) SPECIMENS
- ; (38) SSN
- ; (39) ACCESSION_#
- ; (40) LRO69_POINTERS
- ; (41)LAB_INSTRUCTS
- ;
- N BLR60NAM,BLR62NAM,BLRSPNS,BLRTOP
- N BLRACCNO
- N BLRDT,BLRI,BLRIFNL,BLRJ,BLRK,BLRLCNT,BLRLI,BLRLRDFN,BLRLST,BLRLSTI,BLROI
- N BLRLTMP,BLRNODS,BLRNODT,BLROERR,BLROLOC,BLRPADD
- N BLRPHRN,BLRPNAM,BLRSEX,BLRSP,BLRT,BLRTI,BLRSSN,BLRTMP
- NEW BLRSDAYS,LRDFN,PASTDAYS,FUTUDAYS
- ;
- ; ^TMP("BLRAG01",$J,DFN,<BLRTI counter>)=data
- K ^TMP("BLRAG01",$J) ;used to keep records for same patient together
- S (BLRACCNO,BLRPAD1,BLRPAD2,BLRPAD3,BLRPADC,BLRPADS,BLRPADZ,BLRSSN,BLRTMP)=""
- D ^XBKVAR S X="ERROR^BLRAGUT",@^%ZOSF("TRAP")
- K BLRIFNL,BLRLTMP
- S (BLRI,BLRLCNT,BLROI,BLRTI)=0
- S BLRDFN=$G(BLRDFN)
- K ^TMP("BLRAG",$J)
- S BLRY="^TMP(""BLRAG"","_$J_")"
- ; LRO69_POINTERS = pointers to the LAB ORDER ENTRY file 69; BLRDT:BLRSP:BLRTEST; passed into BLR DELETE TEST
- S BLRTMP($J,0)="ERROR_ID"
- ;
- ; Use the 'Return Days To Accession' XPAR Parameter to determine how many days to go back and forward.
- ; If the parameter is zero, use 90 Days.
- D RETDTA^BLRAG10(.BLRSDAYS) ; Get 'Return Days To Accession' XPAR Parameter
- S:+$G(BLRUSRDY) BLRSDAYS=BLRUSRDY ; If user over-ride passed in, then use that
- ;
- ; Set 'How many days in the past' Variable
- S PASTDAYS=$S(BLRSDAYS:$$HTFM^XLFDT(+$H-(BLRSDAYS+1)),1:$$HTFM^XLFDT(+$H-91))
- ;
- ; Set 'How many days in the future' Variable
- S FUTUDAYS=+$O(^LRO(69,"AA"),-1) ; Get "last" Date in Lab Order Entry (#69) file
- S FUTUDAYS=$S(BLRSDAYS:$$HTFM^XLFDT(+$H+BLRSDAYS),FUTUDAYS>$$DT^XLFDT:FUTUDAYS,1:$$HTFM^XLFDT(+$H+89))
- ;
- S LRDFN=$S(+$G(BLRDFN):+$G(^DPT(BLRDFN,"LR")),1:0) ; Set LRDFN variable
- ;
- I LRDFN D
- . S BLRDT=PASTDAYS
- . F S BLRDT=$O(^LRO(69,"D",LRDFN,BLRDT)) Q:BLRDT'>0!(BLRDT>FUTUDAYS) D ; date level
- ..S BLRSP=0 F S BLRSP=$O(^LRO(69,"D",LRDFN,BLRDT,BLRSP)) Q:BLRSP'>0 D ; specimen mult level
- ...D ANA1(BLRDT,BLRSP,.BLRTI)
- ;
- I LRDFN<1 D
- . S BLRDT=PASTDAYS
- . F S BLRDT=$O(^LRO(69,BLRDT)) Q:BLRDT'>0!(BLRDT>FUTUDAYS) D ; date level
- ..S BLRSP=0 F S BLRSP=$O(^LRO(69,BLRDT,1,BLRSP)) Q:BLRSP'>0 D ; specimen mult level
- ...D ANA1(BLRDT,BLRSP,.BLRTI)
- ;
- D ANAHD
- S BLRJ="" F S BLRJ=$O(^TMP("BLRAG01",$J,BLRJ)) Q:BLRJ="" D
- .S BLRK="" F S BLRK=$O(^TMP("BLRAG01",$J,BLRJ,BLRK)) Q:BLRK="" D
- ..S BLRI=BLRI+1
- ..S ^TMP("BLRAG",$J,BLRI)=^TMP("BLRAG01",$J,BLRJ,BLRK)
- ;
- ;S BLRI=BLRI+1
- ;S ^TMP("BLRAG",$J,BLRI)=$C(31)
- K ^TMP("BLRAG01",$J)
- Q
- ;
- ANA1(BLRDT,BLRSP,BLRTI) ;
- ; BLRDT = date in FM format; pointer to LAB ORDER ENTRY file ^LRO(69,BLRDT
- ; BLRSP = Specimen pointer to LAB ORDER ENTRY file ^LRO(69,BLRDT,1,BLRSP
- ; BLRTI = counter for global array entries
- S BLRNODS=$G(^LRO(69,BLRDT,1,BLRSP,0)) ;get specimen mult node
- Q:$G(BLRNODS)=""
- Q:$P(BLRNODS,U,4)="LC" ;do not include LAB COLLECT
- S BLRSPNS="" ; list of specimen names delimited by pipe |
- S BLRK=0 F S BLRK=$O(^LRO(69,BLRDT,1,BLRSP,4,BLRK)) Q:BLRK'>0 D
- .S BLRTOP=$P($G(^LRO(69,BLRDT,1,BLRSP,4,BLRK,0)),U,1)
- .S BLRSPNS=$S(BLRSPNS'="":"|",1:"")_$$GET1^DIQ(61,BLRTOP_",",.01)
- S BLR62NAM=$P($G(^LAB(62,+$P(BLRNODS,U,3),0)),U,1)
- S BLRORD=$P($G(^LRO(69,BLRDT,1,BLRSP,.1)),U,1)
- Q:$G(BLRORD)=""
- S BLRT=0 F S BLRT=$O(^LRO(69,BLRDT,1,BLRSP,2,BLRT)) Q:BLRT'>0 D ;test mult level
- .S BLRNODT=$G(^LRO(69,BLRDT,1,BLRSP,2,BLRT,0)) ;get test mult node
- .I $P(BLRNODT,U,3)="",$P(BLRNODT,U,9)'="CA" D ;If no accession date ...
- ..S BLRLRDFN=$P(BLRNODS,U,1) ;get lab data IEN
- ..S BLRLRND=$G(^LR(BLRLRDFN,0))
- ..I $P(BLRLRND,U,2)=2 D
- ...; S BLR60NAM=$$GET1^DIQ(60,+$P(BLRNODT,U,1)_",",.01) ;get test name
- ...S BLR60NAM=$$TESTNAME^BLRAGUT(+$P(BLRNODT,U,1)) ;get test name
- ...K BLRINST S BLRINST=""
- ...D INST(+$P(BLRNODT,U,1),+$P(BLRNODS,U,3),.BLRINST) ;get lab instructions
- ...S BLRPDFN=$P(BLRLRND,U,3) ;get patient IEN
- ...I ('$G(BLRDFN))!(BLRDFN=BLRPDFN) D
- ....S BLRPNAM=$P(^DPT(BLRPDFN,0),U,1) ;get patient name
- ....S BLRPHRN=$$HRN^AUPNPAT(BLRPDFN,DUZ(2)) ;get patient HRN
- ....S BLRPDOB=$$DOB^AUPNPAT(BLRPDFN) ;get patient DOB
- ....S BLRPSEX=$$SEX^AUPNPAT(BLRPDFN) ;get patient gender
- ....S BLRPADD=$G(^DPT(BLRPDFN,.11)) ;get patient address node
- ....S BLRSSN=$$SSN^AUPNPAT(BLRPDFN) ;get patient SSN
- ....S BLROERR=$P(BLRNODT,U,7) ;get order IEN
- ....S BLRACCNO=$$GACE69^BLRAGUT(BLRDT,BLRSP,BLRT) ;get accession number
- ....S BLRIFNL(1)=BLROERR
- ....K BLRDLST,BLRFLST
- ....S (BLRDLST,BLRFLST)=""
- ....D GET4V11^ORWORR(.BLRFLST,"",0,.BLRIFNL)
- ....D DETAIL^ORWOR(.BLRDLST,BLROERR)
- ....S BLRTI=BLRTI+1
- ....S ^TMP("BLRAG01",$J,BLRPDFN,BLRTI)=BLRPDFN_U_BLRPNAM_U_BLRPHRN_U_BLRPDOB_U
- ....S BLRTMP=""
- ....S BLRLSTI=$O(BLRFLST(0))
- ....S BLRTMP=$E($P(BLRFLST(BLRLSTI),U,1),2,$L(BLRFLST(BLRLSTI)))
- ....F BLRJ=2:1:18 D
- .....S $P(BLRTMP,U,BLRJ)=$P(BLRFLST(BLRLSTI),U,BLRJ)
- ....S BLRTI=BLRTI+1
- ....S ^TMP("BLRAG01",$J,BLRPDFN,BLRTI)=BLRTMP_U
- ....F S BLRLSTI=$O(BLRFLST(BLRLSTI)) Q:BLRLSTI="" D
- .....S BLRTI=BLRTI+1
- .....S ^TMP("BLRAG01",$J,BLRPDFN,BLRTI)=$E(BLRFLST(BLRLSTI),2,$L(BLRFLST(BLRLSTI)))
- ....S BLRTI=BLRTI+1,^TMP("BLRAG01",$J,BLRPDFN,BLRTI)=U
- ....S BLRLSTI=0 F S BLRLSTI=$O(^TMP("ORTXT",$J,BLRLSTI)) Q:BLRLSTI="" D
- .....S BLRTI=BLRTI+1
- .....S ^TMP("BLRAG01",$J,BLRPDFN,BLRTI)=^TMP("ORTXT",$J,BLRLSTI)_"|"
- ....S BLRTMP1=U_$P(BLRPADD,U,1)_U_$P(BLRPADD,U,2)_U_$P(BLRPADD,U,3)_U_$P(BLRPADD,U,4)_U_$P(BLRPADD,U,5)_U
- ....S BLRTMP1=BLRTMP1_$P(BLRPADD,U,6)_U_BLRPSEX_U_$P(BLRNODS,U,4)_U_$P(BLRNODS,U,5)_U
- ....S BLRTMP1=BLRTMP1_BLRORD_U_BLR60NAM_U_BLR62NAM_U_BLRSPNS_U_BLRSSN_U_BLRACCNO_U_BLRDT_":"_BLRSP_":"_BLRT_U
- ....S BLRTI=BLRTI+1
- ....S ^TMP("BLRAG01",$J,BLRPDFN,BLRTI)=BLRTMP1
- ....S BLRTMP1=""
- ....S BLRD="" F S BLRD=$O(BLRINST(BLRD)) Q:BLRD="" S BLRTI=BLRTI+1 S ^TMP("BLRAG01",$J,BLRPDFN,BLRTI)=BLRINST(BLRD)_"|"
- ....S BLRTI=BLRTI+1,^TMP("BLRAG01",$J,BLRPDFN,BLRTI)="~~~"_$C(30)
- Q
- ;
- ANAHD ;
- ; 0 1 2 3
- S BLRTMP="T00020DFN^T00020PNAME^T00020HRN^T00020DOB^"
- ; 4 5 6 7 8 9
- S BLRTMP=BLRTMP_"T00020IFN^T00020Grp^T00020ActTm^T00020StrtTm^T00020StopTm^T00020Sts^"
- ; 10 11 12 13 14 15
- S BLRTMP=BLRTMP_"T00020Sig^T00020Nrs^T00020Clk^T00020PrvID^T00020PrvNam^T00020ActDA^"
- ; 16 17 18 19 20 21
- S BLRTMP=BLRTMP_"T00020Flag^T00020DCType^T00020ChrtRev^T00020DEA#^^T00020SCHEDULE^"
- ; 22 23
- S BLRTMP=BLRTMP_"T00900ORDER_TEXT^T00900DETAIL_TEXT^"
- ; 24 25 26 27 28 29 30
- S BLRTMP=BLRTMP_"T00020STREET_LINE1^T00020STREET_LINE2^T00020STREET_LINE3^T00020CITY^T00020STATE^T00020ZIP^T00020SEX^"
- ; 31 32 33 34 35
- S BLRTMP=BLRTMP_"T00020COLLECTION_TYPE^T00020DATE_TIME_ORDERED^T00020LAB_ORDER_#^T00020TEST_NAME^T00020COLLECTION_SAMPLE^"
- ; 36 37 38 39 40
- S BLRTMP=BLRTMP_"T00020SPECIMENS^T00020SSN^T00020ACCESSION_#^T00020LRO69_POINTERS^T00500LAB_INSTRUCTS"
- S ^TMP("BLRAG",$J,0)=BLRTMP_"~~~"_$C(30)
- Q
- ;
- INST(BLRLRDFN,BLRCS,BLRRET) ; get lab instructions for given lab test and collection sample
- ; BLRLRDFN = pointer to LABORATORY TEST file 60
- ; BLRCS = pointer to COLLECTION SAMPLE file 62
- ; BLRRET = returned lab instructions array
- ; BLRRET(COUNT)=TEXT
- N BLRD,BLRCSIEN
- S BLRRET=""
- S BLRCSIEN=$O(^LAB(60,BLRLRDFN,3,"B",BLRCS,0))
- Q:BLRCSIEN=""
- S BLRD=0 F S BLRD=$O(^LAB(60,BLRLRDFN,3,BLRCSIEN,2,BLRD)) Q:BLRD'>0 D
- .S BLRRET(BLRD)=^LAB(60,BLRLRDFN,3,BLRCSIEN,2,BLRD,0)
- Q
- ;
- PTC(BLRY) ; rpc to return the value of the BLR PT CONFIRM parameter
- ; RPC: BLR PT CONFIRM ENABLED
- ; Returns Patient Confirmation enabled; 0='no' (default); 1='yes'
- N BLRDOM,BLRENT,BLRI,BLRPAR
- K ^TMP("BLRAG",$J)
- D ^XBKVAR S X="ERROR^BLRAGUT",@^%ZOSF("TRAP")
- S BLRI=0
- S BLRY="^TMP(""BLRAG"","_$J_")"
- S ^TMP("BLRAG",$J,BLRI)="T00020PT_CONFIRM"_$C(30)
- S BLRDOM=$$GET1^DIQ(8989.3,"1,",.01,"I")
- S BLRENT=BLRDOM_";"_"DIC(4.2,"
- S BLRPAR=$O(^XTV(8989.51,"B","BLR PT CONFIRM",0))
- S BLRRET=$$GET^XPAR(BLRENT,BLRPAR,1,"Q")
- S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)=$S(BLRRET'="":BLRRET,1:0)_$C(30)
- ;S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)=$C(31)
- Q
- ;
- PTCS(BLRY,BLRDT,BLRSPN,BLRUSER,BLRDTCF,BLRMETH) ;rpc to store Patient Confirmation data to the Specimen Multiple of the LAB ORDER ENTRY file
- ; RPC: BLR PT CONFIRM STORE
- ; BLRDT = (required) order date in external format - pointer to LAB ORDER ENTRY file 69
- ; BLRSPN = (required) specimen number - pointer to specimen multiple in LAB ORDER ENTRY file 69
- ; BLRUSER = (required) user that did confirmation - pointer to NEW PERSON file 200
- ; BLRDTCF = (optional) Date/Time of user confirmation in external format - defaults to 'today'
- ; BLRMETH = (optional) method of confirmation - free text
- N BLRI,BLRM
- K ^TMP("BLRAG",$J)
- D ^XBKVAR S X="ERROR^BLRAGUT",@^%ZOSF("TRAP")
- S BLRI=0
- S BLRY="^TMP(""BLRAG"","_$J_")"
- S ^TMP("BLRAG",$J,BLRI)="T00020ERROR_ID" ;0=clean; Text=error
- ;convert external date to FM format
- S X=$G(BLRDT),%DT="XT" D ^%DT S BLRDT=$P(Y,".")
- ;error if invalid date passed in
- I $$FR^XLFDT($G(BLRDT)) D ERR^BLRAGUT("BLRAG01: Invalid order date.") Q
- I '$G(BLRSPN) D ERR^BLRAGUT("BLRAG01: Invalid Specimen Number.") Q
- I '$G(BLRUSER)!'$D(^VA(200,BLRUSER)) D ERR^BLRAGUT("BLRAG01: Invalid User.") Q
- S BLRORD=$P(^LRO(69,BLRDT,1,BLRSPN,.1),U,1)
- I '$D(^LRO(69,BLRDT,1,BLRSPN))!(BLRORD="") D ERR^BLRAGUT("BLRAG01: Invalid Order.") Q
- ;;
- TSTART
- L +^LRO(69,"C",+$G(BLRORD)):1
- ;L +^LRO(69,BLRDT,1,BLRSPN):5
- I '$T TROLLBACK D ERR^BLRAGUT("BLRAG01: File being modified elsewhere.") Q
- ;if confirmation date is null, default to NOW
- I $G(BLRDTCF)="" S BLRDTCF=$$HTFM^XLFDT($H)
- E D
- .;convert external date to FM format
- .S X=BLRDTCF,%DT="XT" D ^%DT S BLRDTCF=Y
- .;default to 'NOW' if invalid date passed in
- .S:$$FR^XLFDT($G(BLRDTCF)) BLRDTCF=$$HTFM^XLFDT($H)
- K BLRM
- S BLRM=""
- S FDA(69.01,BLRSPN_","_+BLRDT_",",21400)=BLRUSER
- S FDA(69.01,BLRSPN_","_+BLRDT_",",21401)=BLRDTCF
- S FDA(69.01,BLRSPN_","_+BLRDT_",",21402)=BLRMETH
- D FILE^DIE("","FDA","BLRM")
- I $D(BLRM("DIERR")) D ERR^BLRAGUT("BLRAG01: "_BLRM("DIERR",1,"TEXT",1)) L -^LRO(69,BLRDT,1,BLRSPN) TROLLBACK Q
- ; L -^LRO(69,BLRDT,1,BLRSPN)
- D UNL69
- TCOMMIT
- ;;
- S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)=0_$C(30)
- ;S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)=$C(31)
- Q
- ;
- UNL69 ;
- L -^LRO(69,"C",+$G(LRORD))
- Q
- BLRAG01 ; IHS/MSC/SAT - LABORATORY ACCESSION GUI RPCS ;
- +1 ;;5.2;IHS LABORATORY;**1031**;NOV 01, 1997;Build 185
- +2 ;
- +3 ; BLR REF LAB USING LEDI - UL^BLRAG02 = return the value of the 'REF LAB USING LEDI?' field in the BLR MASTER CONTROL file
- +4 ; BLR ICD LOOKUP - ICDLKUP^BLRAG07 = ICD code lookup
- +5 ; BLR ORDER REASON LKUP - ORL^BLRAG07 = return order reasons from file 100.03
- +6 ; BLR PATIENT LOOKUP - PTLK^BLRAG04 = Patient Lookup
- +7 ; BLR PRINTERS AVAILABLE - DEVICE^BLRAG10 = return available printers from the DEVICE file
- +8 ; BLR USER LOOKUP - NP^BLRAG06 = return entries from the NEW PERSON table 200 that are 'active'
- +9 ;
- +10 ; BLR ACCESSION - ACC^BLRAG05 = lab accession processor
- +11 ; BLR ACCESSION PRINT - ABR^BLRAG02 = reprint accession label or manifest
- +12 ; BLR ALL NON-ACCESSIONED - ANA^BLRAG01 = return all non-accessioned lab records
- +13 ; BLR ALL-ACCESSIONED - ABD^BLRAG02 = return all accessioned records for given date range
- +14 ; BLR COLLECTION INFO - BLC^BLRAG06 = check BLR PT CONFIRM parameter and return insurances for patient
- +15 ; BLR DELETE TEST - DELTST^BLRAG08 = Cancel tests - Test are no longer deleted, instead the status is changed to Not Performed.
- +16 ; BLR ORDER/TEST STATUS - LROS^BLRAG03 = return order/test status for given patient and date range
- +17 ;
- +18 ; BLR SHIP CONF - SC^BLRAG09A = select a shipping configuration
- +19 ; BLR MANIFEST BUILD - BM^BLRAG09B = build a shipping manifest
- +20 ; BLR MANIFEST CLOSE/SHIP - CLSHIP^BLRAG09C = Close/ship a shipping manifest
- +21 ; BLR MANIFEST DISPLAY - DISP^BLRAG09G = screen formatted text for manifest display
- +22 ; BLR MANIFEST START - SMONLY^BLRAG09C = Start a shipping manifest only, no building
- +23 ; BLR MANIFEST TEST ADD - ADDTEST^BLRAG09C= Add tests to an existing manifest
- +24 ; BLR MANIFEST TEST REMOVE - REMVTST^BLRAG09C= Remove a test from manifest - actually flags test as "removed".
- +25 ; BLR MANIFEST TESTS TO ADD- TARPC^BLRAG09B = return tests that can be added to a manifest
- +26 ;
- +27 ;return all non-accessioned lab records - RPC
- ANA(BLRY,BLRDFN,BLRUSRDY) ;return appointment data for given patient - RPC
- +1 ; RPC Name is BLR ALL NON-ACCESSIONED
- +2 ;INPUT:
- +3 ; .BLRY = returned pointer to appointment data
- +4 ; BLRDFN = (optional) return all non-accessioned lab records for this
- +5 ; given patient only
- +6 ; return for all patients of this parameter
- +7 ; is not defined
- +8 ; BLRUSRDY = Temporary User Override of the BLR DAYS TO ACCESSION XPAR Parameter
- +9 ;
- +10 ;RETURNS:
- +11 ; (0) DFN
- +12 ; (1) PNAME
- +13 ; (2) HRN
- +14 ; (3) DOB
- +15 ; (5) IFN
- +16 ; (6) Grp
- +17 ; (7) ActTm
- +18 ; (8) StrtTm
- +19 ; (9) StopTm
- +20 ; (10) Sts
- +21 ; (11) Sig
- +22 ; (12) Nrs
- +23 ; (13) Clk
- +24 ; (14) PrvID
- +25 ; (15) PrvNam
- +26 ; (16) ActDA
- +27 ; (17) Flag
- +28 ; (18) DCType
- +29 ; (19) ChrtRev
- +30 ; (20) DEA#
- +31 ; (21) <NOT USED>
- +32 ; (22) SCHEDULE
- +33 ; (23) ORDER_TEXT
- +34 ; (24) DETAIL_TEXT
- +35 ; (25) STREET_LINE1
- +36 ; (26) STREET_LINE2
- +37 ; (27) STREET_LINE3
- +38 ; (28) CITY
- +39 ; (29) STATE
- +40 ; (30) ZIP
- +41 ; (31) SEX
- +42 ; (32) COLLECTION_TYPE
- +43 ; (33) DATE_TIME_ORDERED
- +44 ; (34) LAB_ORDER_#
- +45 ; (35) TEST_NAME
- +46 ; (36) COLLECTION_SAMPLE
- +47 ; (37) SPECIMENS
- +48 ; (38) SSN
- +49 ; (39) ACCESSION_#
- +50 ; (40) LRO69_POINTERS
- +51 ; (41)LAB_INSTRUCTS
- +52 ;
- +53 NEW BLR60NAM,BLR62NAM,BLRSPNS,BLRTOP
- +54 NEW BLRACCNO
- +55 NEW BLRDT,BLRI,BLRIFNL,BLRJ,BLRK,BLRLCNT,BLRLI,BLRLRDFN,BLRLST,BLRLSTI,BLROI
- +56 NEW BLRLTMP,BLRNODS,BLRNODT,BLROERR,BLROLOC,BLRPADD
- +57 NEW BLRPHRN,BLRPNAM,BLRSEX,BLRSP,BLRT,BLRTI,BLRSSN,BLRTMP
- +58 NEW BLRSDAYS,LRDFN,PASTDAYS,FUTUDAYS
- +59 ;
- +60 ; ^TMP("BLRAG01",$J,DFN,<BLRTI counter>)=data
- +61 ;used to keep records for same patient together
- KILL ^TMP("BLRAG01",$JOB)
- +62 SET (BLRACCNO,BLRPAD1,BLRPAD2,BLRPAD3,BLRPADC,BLRPADS,BLRPADZ,BLRSSN,BLRTMP)=""
- +63 DO ^XBKVAR
- SET X="ERROR^BLRAGUT"
- SET @^%ZOSF("TRAP")
- +64 KILL BLRIFNL,BLRLTMP
- +65 SET (BLRI,BLRLCNT,BLROI,BLRTI)=0
- +66 SET BLRDFN=$GET(BLRDFN)
- +67 KILL ^TMP("BLRAG",$JOB)
- +68 SET BLRY="^TMP(""BLRAG"","_$JOB_")"
- +69 ; LRO69_POINTERS = pointers to the LAB ORDER ENTRY file 69; BLRDT:BLRSP:BLRTEST; passed into BLR DELETE TEST
- +70 SET BLRTMP($JOB,0)="ERROR_ID"
- +71 ;
- +72 ; Use the 'Return Days To Accession' XPAR Parameter to determine how many days to go back and forward.
- +73 ; If the parameter is zero, use 90 Days.
- +74 ; Get 'Return Days To Accession' XPAR Parameter
- DO RETDTA^BLRAG10(.BLRSDAYS)
- +75 ; If user over-ride passed in, then use that
- IF +$GET(BLRUSRDY)
- SET BLRSDAYS=BLRUSRDY
- +76 ;
- +77 ; Set 'How many days in the past' Variable
- +78 SET PASTDAYS=$SELECT(BLRSDAYS:$$HTFM^XLFDT(+$HOROLOG-(BLRSDAYS+1)),1:$$HTFM^XLFDT(+$HOROLOG-91))
- +79 ;
- +80 ; Set 'How many days in the future' Variable
- +81 ; Get "last" Date in Lab Order Entry (#69) file
- SET FUTUDAYS=+$ORDER(^LRO(69,"AA"),-1)
- +82 SET FUTUDAYS=$SELECT(BLRSDAYS:$$HTFM^XLFDT(+$HOROLOG+BLRSDAYS),FUTUDAYS>$$DT^XLFDT:FUTUDAYS,1:$$HTFM^XLFDT(+$HOROLOG+89))
- +83 ;
- +84 ; Set LRDFN variable
- SET LRDFN=$SELECT(+$GET(BLRDFN):+$GET(^DPT(BLRDFN,"LR")),1:0)
- +85 ;
- +86 IF LRDFN
- Begin DoDot:1
- +87 SET BLRDT=PASTDAYS
- +88 ; date level
- FOR
- SET BLRDT=$ORDER(^LRO(69,"D",LRDFN,BLRDT))
- IF BLRDT'>0!(BLRDT>FUTUDAYS)
- QUIT
- Begin DoDot:2
- +89 ; specimen mult level
- SET BLRSP=0
- FOR
- SET BLRSP=$ORDER(^LRO(69,"D",LRDFN,BLRDT,BLRSP))
- IF BLRSP'>0
- QUIT
- Begin DoDot:3
- +90 DO ANA1(BLRDT,BLRSP,.BLRTI)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +91 ;
- +92 IF LRDFN<1
- Begin DoDot:1
- +93 SET BLRDT=PASTDAYS
- +94 ; date level
- FOR
- SET BLRDT=$ORDER(^LRO(69,BLRDT))
- IF BLRDT'>0!(BLRDT>FUTUDAYS)
- QUIT
- Begin DoDot:2
- +95 ; specimen mult level
- SET BLRSP=0
- FOR
- SET BLRSP=$ORDER(^LRO(69,BLRDT,1,BLRSP))
- IF BLRSP'>0
- QUIT
- Begin DoDot:3
- +96 DO ANA1(BLRDT,BLRSP,.BLRTI)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +97 ;
- +98 DO ANAHD
- +99 SET BLRJ=""
- FOR
- SET BLRJ=$ORDER(^TMP("BLRAG01",$JOB,BLRJ))
- IF BLRJ=""
- QUIT
- Begin DoDot:1
- +100 SET BLRK=""
- FOR
- SET BLRK=$ORDER(^TMP("BLRAG01",$JOB,BLRJ,BLRK))
- IF BLRK=""
- QUIT
- Begin DoDot:2
- +101 SET BLRI=BLRI+1
- +102 SET ^TMP("BLRAG",$JOB,BLRI)=^TMP("BLRAG01",$JOB,BLRJ,BLRK)
- End DoDot:2
- End DoDot:1
- +103 ;
- +104 ;S BLRI=BLRI+1
- +105 ;S ^TMP("BLRAG",$J,BLRI)=$C(31)
- +106 KILL ^TMP("BLRAG01",$JOB)
- +107 QUIT
- +108 ;
- ANA1(BLRDT,BLRSP,BLRTI) ;
- +1 ; BLRDT = date in FM format; pointer to LAB ORDER ENTRY file ^LRO(69,BLRDT
- +2 ; BLRSP = Specimen pointer to LAB ORDER ENTRY file ^LRO(69,BLRDT,1,BLRSP
- +3 ; BLRTI = counter for global array entries
- +4 ;get specimen mult node
- SET BLRNODS=$GET(^LRO(69,BLRDT,1,BLRSP,0))
- +5 IF $GET(BLRNODS)=""
- QUIT
- +6 ;do not include LAB COLLECT
- IF $PIECE(BLRNODS,U,4)="LC"
- QUIT
- +7 ; list of specimen names delimited by pipe |
- SET BLRSPNS=""
- +8 SET BLRK=0
- FOR
- SET BLRK=$ORDER(^LRO(69,BLRDT,1,BLRSP,4,BLRK))
- IF BLRK'>0
- QUIT
- Begin DoDot:1
- +9 SET BLRTOP=$PIECE($GET(^LRO(69,BLRDT,1,BLRSP,4,BLRK,0)),U,1)
- +10 SET BLRSPNS=$SELECT(BLRSPNS'="":"|",1:"")_$$GET1^DIQ(61,BLRTOP_",",.01)
- End DoDot:1
- +11 SET BLR62NAM=$PIECE($GET(^LAB(62,+$PIECE(BLRNODS,U,3),0)),U,1)
- +12 SET BLRORD=$PIECE($GET(^LRO(69,BLRDT,1,BLRSP,.1)),U,1)
- +13 IF $GET(BLRORD)=""
- QUIT
- +14 ;test mult level
- SET BLRT=0
- FOR
- SET BLRT=$ORDER(^LRO(69,BLRDT,1,BLRSP,2,BLRT))
- IF BLRT'>0
- QUIT
- Begin DoDot:1
- +15 ;get test mult node
- SET BLRNODT=$GET(^LRO(69,BLRDT,1,BLRSP,2,BLRT,0))
- +16 ;If no accession date ...
- IF $PIECE(BLRNODT,U,3)=""
- IF $PIECE(BLRNODT,U,9)'="CA"
- Begin DoDot:2
- +17 ;get lab data IEN
- SET BLRLRDFN=$PIECE(BLRNODS,U,1)
- +18 SET BLRLRND=$GET(^LR(BLRLRDFN,0))
- +19 IF $PIECE(BLRLRND,U,2)=2
- Begin DoDot:3
- +20 ; S BLR60NAM=$$GET1^DIQ(60,+$P(BLRNODT,U,1)_",",.01) ;get test name
- +21 ;get test name
- SET BLR60NAM=$$TESTNAME^BLRAGUT(+$PIECE(BLRNODT,U,1))
- +22 KILL BLRINST
- SET BLRINST=""
- +23 ;get lab instructions
- DO INST(+$PIECE(BLRNODT,U,1),+$PIECE(BLRNODS,U,3),.BLRINST)
- +24 ;get patient IEN
- SET BLRPDFN=$PIECE(BLRLRND,U,3)
- +25 IF ('$GET(BLRDFN))!(BLRDFN=BLRPDFN)
- Begin DoDot:4
- +26 ;get patient name
- SET BLRPNAM=$PIECE(^DPT(BLRPDFN,0),U,1)
- +27 ;get patient HRN
- SET BLRPHRN=$$HRN^AUPNPAT(BLRPDFN,DUZ(2))
- +28 ;get patient DOB
- SET BLRPDOB=$$DOB^AUPNPAT(BLRPDFN)
- +29 ;get patient gender
- SET BLRPSEX=$$SEX^AUPNPAT(BLRPDFN)
- +30 ;get patient address node
- SET BLRPADD=$GET(^DPT(BLRPDFN,.11))
- +31 ;get patient SSN
- SET BLRSSN=$$SSN^AUPNPAT(BLRPDFN)
- +32 ;get order IEN
- SET BLROERR=$PIECE(BLRNODT,U,7)
- +33 ;get accession number
- SET BLRACCNO=$$GACE69^BLRAGUT(BLRDT,BLRSP,BLRT)
- +34 SET BLRIFNL(1)=BLROERR
- +35 KILL BLRDLST,BLRFLST
- +36 SET (BLRDLST,BLRFLST)=""
- +37 DO GET4V11^ORWORR(.BLRFLST,"",0,.BLRIFNL)
- +38 DO DETAIL^ORWOR(.BLRDLST,BLROERR)
- +39 SET BLRTI=BLRTI+1
- +40 SET ^TMP("BLRAG01",$JOB,BLRPDFN,BLRTI)=BLRPDFN_U_BLRPNAM_U_BLRPHRN_U_BLRPDOB_U
- +41 SET BLRTMP=""
- +42 SET BLRLSTI=$ORDER(BLRFLST(0))
- +43 SET BLRTMP=$EXTRACT($PIECE(BLRFLST(BLRLSTI),U,1),2,$LENGTH(BLRFLST(BLRLSTI)))
- +44 FOR BLRJ=2:1:18
- Begin DoDot:5
- +45 SET $PIECE(BLRTMP,U,BLRJ)=$PIECE(BLRFLST(BLRLSTI),U,BLRJ)
- End DoDot:5
- +46 SET BLRTI=BLRTI+1
- +47 SET ^TMP("BLRAG01",$JOB,BLRPDFN,BLRTI)=BLRTMP_U
- +48 FOR
- SET BLRLSTI=$ORDER(BLRFLST(BLRLSTI))
- IF BLRLSTI=""
- QUIT
- Begin DoDot:5
- +49 SET BLRTI=BLRTI+1
- +50 SET ^TMP("BLRAG01",$JOB,BLRPDFN,BLRTI)=$EXTRACT(BLRFLST(BLRLSTI),2,$LENGTH(BLRFLST(BLRLSTI)))
- End DoDot:5
- +51 SET BLRTI=BLRTI+1
- SET ^TMP("BLRAG01",$JOB,BLRPDFN,BLRTI)=U
- +52 SET BLRLSTI=0
- FOR
- SET BLRLSTI=$ORDER(^TMP("ORTXT",$JOB,BLRLSTI))
- IF BLRLSTI=""
- QUIT
- Begin DoDot:5
- +53 SET BLRTI=BLRTI+1
- +54 SET ^TMP("BLRAG01",$JOB,BLRPDFN,BLRTI)=^TMP("ORTXT",$JOB,BLRLSTI)_"|"
- End DoDot:5
- +55 SET BLRTMP1=U_$PIECE(BLRPADD,U,1)_U_$PIECE(BLRPADD,U,2)_U_$PIECE(BLRPADD,U,3)_U_$PIECE(BLRPADD,U,4)_U_$PIECE(BLRPADD,U,5)_U
- +56 SET BLRTMP1=BLRTMP1_$PIECE(BLRPADD,U,6)_U_BLRPSEX_U_$PIECE(BLRNODS,U,4)_U_$PIECE(BLRNODS,U,5)_U
- +57 SET BLRTMP1=BLRTMP1_BLRORD_U_BLR60NAM_U_BLR62NAM_U_BLRSPNS_U_BLRSSN_U_BLRACCNO_U_BLRDT_":"_BLRSP_":"_BLRT_U
- +58 SET BLRTI=BLRTI+1
- +59 SET ^TMP("BLRAG01",$JOB,BLRPDFN,BLRTI)=BLRTMP1
- +60 SET BLRTMP1=""
- +61 SET BLRD=""
- FOR
- SET BLRD=$ORDER(BLRINST(BLRD))
- IF BLRD=""
- QUIT
- SET BLRTI=BLRTI+1
- SET ^TMP("BLRAG01",$JOB,BLRPDFN,BLRTI)=BLRINST(BLRD)_"|"
- +62 SET BLRTI=BLRTI+1
- SET ^TMP("BLRAG01",$JOB,BLRPDFN,BLRTI)="~~~"_$CHAR(30)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +63 QUIT
- +64 ;
- ANAHD ;
- +1 ; 0 1 2 3
- +2 SET BLRTMP="T00020DFN^T00020PNAME^T00020HRN^T00020DOB^"
- +3 ; 4 5 6 7 8 9
- +4 SET BLRTMP=BLRTMP_"T00020IFN^T00020Grp^T00020ActTm^T00020StrtTm^T00020StopTm^T00020Sts^"
- +5 ; 10 11 12 13 14 15
- +6 SET BLRTMP=BLRTMP_"T00020Sig^T00020Nrs^T00020Clk^T00020PrvID^T00020PrvNam^T00020ActDA^"
- +7 ; 16 17 18 19 20 21
- +8 SET BLRTMP=BLRTMP_"T00020Flag^T00020DCType^T00020ChrtRev^T00020DEA#^^T00020SCHEDULE^"
- +9 ; 22 23
- +10 SET BLRTMP=BLRTMP_"T00900ORDER_TEXT^T00900DETAIL_TEXT^"
- +11 ; 24 25 26 27 28 29 30
- +12 SET BLRTMP=BLRTMP_"T00020STREET_LINE1^T00020STREET_LINE2^T00020STREET_LINE3^T00020CITY^T00020STATE^T00020ZIP^T00020SEX^"
- +13 ; 31 32 33 34 35
- +14 SET BLRTMP=BLRTMP_"T00020COLLECTION_TYPE^T00020DATE_TIME_ORDERED^T00020LAB_ORDER_#^T00020TEST_NAME^T00020COLLECTION_SAMPLE^"
- +15 ; 36 37 38 39 40
- +16 SET BLRTMP=BLRTMP_"T00020SPECIMENS^T00020SSN^T00020ACCESSION_#^T00020LRO69_POINTERS^T00500LAB_INSTRUCTS"
- +17 SET ^TMP("BLRAG",$JOB,0)=BLRTMP_"~~~"_$CHAR(30)
- +18 QUIT
- +19 ;
- INST(BLRLRDFN,BLRCS,BLRRET) ; get lab instructions for given lab test and collection sample
- +1 ; BLRLRDFN = pointer to LABORATORY TEST file 60
- +2 ; BLRCS = pointer to COLLECTION SAMPLE file 62
- +3 ; BLRRET = returned lab instructions array
- +4 ; BLRRET(COUNT)=TEXT
- +5 NEW BLRD,BLRCSIEN
- +6 SET BLRRET=""
- +7 SET BLRCSIEN=$ORDER(^LAB(60,BLRLRDFN,3,"B",BLRCS,0))
- +8 IF BLRCSIEN=""
- QUIT
- +9 SET BLRD=0
- FOR
- SET BLRD=$ORDER(^LAB(60,BLRLRDFN,3,BLRCSIEN,2,BLRD))
- IF BLRD'>0
- QUIT
- Begin DoDot:1
- +10 SET BLRRET(BLRD)=^LAB(60,BLRLRDFN,3,BLRCSIEN,2,BLRD,0)
- End DoDot:1
- +11 QUIT
- +12 ;
- PTC(BLRY) ; rpc to return the value of the BLR PT CONFIRM parameter
- +1 ; RPC: BLR PT CONFIRM ENABLED
- +2 ; Returns Patient Confirmation enabled; 0='no' (default); 1='yes'
- +3 NEW BLRDOM,BLRENT,BLRI,BLRPAR
- +4 KILL ^TMP("BLRAG",$JOB)
- +5 DO ^XBKVAR
- SET X="ERROR^BLRAGUT"
- SET @^%ZOSF("TRAP")
- +6 SET BLRI=0
- +7 SET BLRY="^TMP(""BLRAG"","_$JOB_")"
- +8 SET ^TMP("BLRAG",$JOB,BLRI)="T00020PT_CONFIRM"_$CHAR(30)
- +9 SET BLRDOM=$$GET1^DIQ(8989.3,"1,",.01,"I")
- +10 SET BLRENT=BLRDOM_";"_"DIC(4.2,"
- +11 SET BLRPAR=$ORDER(^XTV(8989.51,"B","BLR PT CONFIRM",0))
- +12 SET BLRRET=$$GET^XPAR(BLRENT,BLRPAR,1,"Q")
- +13 SET BLRI=BLRI+1
- SET ^TMP("BLRAG",$JOB,BLRI)=$SELECT(BLRRET'="":BLRRET,1:0)_$CHAR(30)
- +14 ;S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)=$C(31)
- +15 QUIT
- +16 ;
- PTCS(BLRY,BLRDT,BLRSPN,BLRUSER,BLRDTCF,BLRMETH) ;rpc to store Patient Confirmation data to the Specimen Multiple of the LAB ORDER ENTRY file
- +1 ; RPC: BLR PT CONFIRM STORE
- +2 ; BLRDT = (required) order date in external format - pointer to LAB ORDER ENTRY file 69
- +3 ; BLRSPN = (required) specimen number - pointer to specimen multiple in LAB ORDER ENTRY file 69
- +4 ; BLRUSER = (required) user that did confirmation - pointer to NEW PERSON file 200
- +5 ; BLRDTCF = (optional) Date/Time of user confirmation in external format - defaults to 'today'
- +6 ; BLRMETH = (optional) method of confirmation - free text
- +7 NEW BLRI,BLRM
- +8 KILL ^TMP("BLRAG",$JOB)
- +9 DO ^XBKVAR
- SET X="ERROR^BLRAGUT"
- SET @^%ZOSF("TRAP")
- +10 SET BLRI=0
- +11 SET BLRY="^TMP(""BLRAG"","_$JOB_")"
- +12 ;0=clean; Text=error
- SET ^TMP("BLRAG",$JOB,BLRI)="T00020ERROR_ID"
- +13 ;convert external date to FM format
- +14 SET X=$GET(BLRDT)
- SET %DT="XT"
- DO ^%DT
- SET BLRDT=$PIECE(Y,".")
- +15 ;error if invalid date passed in
- +16 IF $$FR^XLFDT($GET(BLRDT))
- DO ERR^BLRAGUT("BLRAG01: Invalid order date.")
- QUIT
- +17 IF '$GET(BLRSPN)
- DO ERR^BLRAGUT("BLRAG01: Invalid Specimen Number.")
- QUIT
- +18 IF '$GET(BLRUSER)!'$DATA(^VA(200,BLRUSER))
- DO ERR^BLRAGUT("BLRAG01: Invalid User.")
- QUIT
- +19 SET BLRORD=$PIECE(^LRO(69,BLRDT,1,BLRSPN,.1),U,1)
- +20 IF '$DATA(^LRO(69,BLRDT,1,BLRSPN))!(BLRORD="")
- DO ERR^BLRAGUT("BLRAG01: Invalid Order.")
- QUIT
- +21 ;;
- +22 TSTART
- +23 LOCK +^LRO(69,"C",+$GET(BLRORD)):1
- +24 ;L +^LRO(69,BLRDT,1,BLRSPN):5
- +25 IF '$TEST
- TROLLBACK
- DO ERR^BLRAGUT("BLRAG01: File being modified elsewhere.")
- QUIT
- +26 ;if confirmation date is null, default to NOW
- +27 IF $GET(BLRDTCF)=""
- SET BLRDTCF=$$HTFM^XLFDT($HOROLOG)
- +28 IF '$TEST
- Begin DoDot:1
- +29 ;convert external date to FM format
- +30 SET X=BLRDTCF
- SET %DT="XT"
- DO ^%DT
- SET BLRDTCF=Y
- +31 ;default to 'NOW' if invalid date passed in
- +32 IF $$FR^XLFDT($GET(BLRDTCF))
- SET BLRDTCF=$$HTFM^XLFDT($HOROLOG)
- End DoDot:1
- +33 KILL BLRM
- +34 SET BLRM=""
- +35 SET FDA(69.01,BLRSPN_","_+BLRDT_",",21400)=BLRUSER
- +36 SET FDA(69.01,BLRSPN_","_+BLRDT_",",21401)=BLRDTCF
- +37 SET FDA(69.01,BLRSPN_","_+BLRDT_",",21402)=BLRMETH
- +38 DO FILE^DIE("","FDA","BLRM")
- +39 IF $DATA(BLRM("DIERR"))
- DO ERR^BLRAGUT("BLRAG01: "_BLRM("DIERR",1,"TEXT",1))
- LOCK -^LRO(69,BLRDT,1,BLRSPN)
- TROLLBACK
- QUIT
- +40 ; L -^LRO(69,BLRDT,1,BLRSPN)
- +41 DO UNL69
- +42 TCOMMIT
- +43 ;;
- +44 SET BLRI=BLRI+1
- SET ^TMP("BLRAG",$JOB,BLRI)=0_$CHAR(30)
- +45 ;S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)=$C(31)
- +46 QUIT
- +47 ;
- UNL69 ;
- +1 LOCK -^LRO(69,"C",+$GET(LRORD))
- +2 QUIT
