- BLRAG06 ; 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
- ;
- BLC(BLRY,BLRDFN) ;check BLR PT CONFIRM parameter and return insurances for patient
- ; RPC = BLR COLLECTION INFO
- ;INPUT:
- ; .BLRY = returned pointer to appointment data
- ; BLRDFN = (required) pointer to VA PATIENT file 2
- ;
- ; Returns in first record:
- ; Patient IEN
- ; Current User IEN
- ; Current User Name
- ; Patient Confirmation enabled; 0='no' (default); 1='yes'
- ; 2nd and following records are INSURANCE_DATA as returned in ^AGINS:
- ; INS_NAME^INS_IEN^??^COVERAGE_NUMBER^ELIGIBILITY_DATE^EXP_DATE^
- ; INS_FILE_POINTER^POLICY_HOLDER_NAME^POLICY^...
- ;
- N BLRI
- N BLRINSD,BLRINSI,BLRINS,BLRPTCF,BLRUSERN
- S (BLRINSD,BLRINSI,BLRINS)=""
- D ^XBKVAR S X="ERROR^BLRAGUT",@^%ZOSF("TRAP")
- K BLRIFNL,BLRLTMP
- S BLRI=0
- K ^TMP("BLRAG",$J)
- S BLRY="^TMP(""BLRAG"","_$J_")"
- S ^TMP("BLRAG",$J,0)="ERROR_ID"
- ;
- I '+$G(BLRDFN) D ERR^BLRAGUT("BLRAG06: Invalid patient.") Q
- I '+$G(DUZ) D ERR^BLRAGUT("BLRAG06: Invalid user defined.") Q
- ;
- S BLRUSERN=$$GET1^DIQ(200,DUZ_",",.01) ;get user name
- S BLRPTCF=$$PTC^BLRAGUT() ;get patient confirmation flag
- S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)=BLRDFN_U_DUZ_U_BLRUSERN_U_BLRPTCF
- K AGINS
- S DFN=BLRDFN
- D ^AGINS
- S BLRINSI="" F S BLRINSI=$O(AGINS(BLRINSI)) Q:BLRINSI="" D
- .S BLRINSD=AGINS(BLRINSI)
- .;S BLRINS=BLRINS_$S(BLRINS'="":"|",1:"")_$P(BLRINSD,U,1)_":"_$P(BLRINSD,U,2)_":"_$P(BLRINSD,U,9)_":"_$P(BLRINSD,U,6)
- .S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)=BLRINSD
- ; 0 1 2 3 4
- S ^TMP("BLRAG",$J,0)="T00020DFN^T00020DEFAULT_USER_IEN^T00020DEFAULT_USER_NAME^T00020PT_CONFIRM^T00400INSURANCE_DATA"
- Q
- ;
- NP(BLRY,BLRPN) ;EP BLR USER LOOKUP remote procedure
- ; return entries from the NEW PERSON table 200 that are 'active'
- ;INPUT:
- ; BLRPN = text representing partial name for NEW PERSON lookup; must be at least 3 characters
- ;RETURN:
- ; Global array containing entries from the NEW PERSON file 200.
- ; NEW_PERSON_IEN^NAME
- N BLRC,BLRN,BLRI,BLRNPS
- ;
- D ^XBKVAR S X="ERROR^BLRAGUT",@^%ZOSF("TRAP")
- S BLRI=0
- K ^TMP("BLRAG",$J)
- S BLRY="^TMP(""BLRAG"","_$J_")"
- S ^TMP("BLRAG",$J,0)="ERROR_ID"
- I $L($G(BLRPN))<3 D ERR^BLRAGUT("BLRAG06: User name lookup requires at least 3 characters.") Q
- S BLRN=$$PREP(BLRPN) F S BLRN=$O(^VA(200,"B",BLRN)) Q:BLRN="" Q:BLRPN'[$E(BLRN,1,$L(BLRPN)) D
- . S BLRC=$O(^VA(200,"B",BLRN,""))
- . S BLRNPS=$G(^VA(200,BLRC,"PS"))
- . I ($P(BLRNPS,U,4)="") D
- . . S BLRI=BLRI+1 S ^TMP("BLRAG",$J,BLRI)=BLRC_U_BLRN
- S ^TMP("BLRAG",$J,0)="T00020NEW_PERSON_IEN^T00020NAME"
- Q
- ;
- PREP(NAME) ;prep input for partial name lookup - decrement last char of name for $O; up-shift all alpha characters
- N BLRL
- Q:$G(NAME)="" -1
- S NAME=$$UPS(NAME)
- Q:$E(NAME,$L(NAME))'?1A NAME
- S BLRL=$E(NAME,$L(NAME))
- S BLRL=$A(BLRL)-1
- Q $E(NAME,1,$L(NAME)-1)_$C(BLRL)_"~"
- ;
- UPS(NAME) ;upshift and check punctuation of input
- N BLRDGC,BLRDGI
- F BLRDGI=1:1:$L(NAME) S BLRDGC=$E(NAME,BLRDGI) D:$$FC1(.BLRDGC,1)
- .S NAME=$E(NAME,0,BLRDGI-1)_BLRDGC_$E(NAME,BLRDGI+1,999)
- .Q
- Q NAME
- ;
- FC1(DGC,DGCOMA) ;Transform single character
- ;Input: DGC=character to transform (pass by reference)
- ; DGCOMA=comma indicator
- ;Output: 1 if value is changed, 0 otherwise
- ;
- S DGC=$E(DGC) Q:'$L(DGC) 0
- ;See if comma stays
- I DGCOMA'=3,DGC?1"," Q 0
- ;Retain uppercase, numeric, hyphen, apostrophe and space
- Q:DGC?1U!(DGC?1N)!(DGC?1"-")!(DGC?1"'")!(DGC?1" ") 0
- ;Retain parenthesis, bracket and brace characters
- Q:DGC?1"("!(DGC?1")")!(DGC?1"[")!(DGC?1"]")!(DGC?1"{")!(DGC?1"}") 0
- ;Transform lowercase to uppercase
- I DGC?1L S DGC=$C($A(DGC)-32) Q 1
- ;Set all other characters to space
- S DGC=" " Q 1
- BLRAG06 ; 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 ;
- BLC(BLRY,BLRDFN) ;check BLR PT CONFIRM parameter and return insurances for patient
- +1 ; RPC = BLR COLLECTION INFO
- +2 ;INPUT:
- +3 ; .BLRY = returned pointer to appointment data
- +4 ; BLRDFN = (required) pointer to VA PATIENT file 2
- +5 ;
- +6 ; Returns in first record:
- +7 ; Patient IEN
- +8 ; Current User IEN
- +9 ; Current User Name
- +10 ; Patient Confirmation enabled; 0='no' (default); 1='yes'
- +11 ; 2nd and following records are INSURANCE_DATA as returned in ^AGINS:
- +12 ; INS_NAME^INS_IEN^??^COVERAGE_NUMBER^ELIGIBILITY_DATE^EXP_DATE^
- +13 ; INS_FILE_POINTER^POLICY_HOLDER_NAME^POLICY^...
- +14 ;
- +15 NEW BLRI
- +16 NEW BLRINSD,BLRINSI,BLRINS,BLRPTCF,BLRUSERN
- +17 SET (BLRINSD,BLRINSI,BLRINS)=""
- +18 DO ^XBKVAR
- SET X="ERROR^BLRAGUT"
- SET @^%ZOSF("TRAP")
- +19 KILL BLRIFNL,BLRLTMP
- +20 SET BLRI=0
- +21 KILL ^TMP("BLRAG",$JOB)
- +22 SET BLRY="^TMP(""BLRAG"","_$JOB_")"
- +23 SET ^TMP("BLRAG",$JOB,0)="ERROR_ID"
- +24 ;
- +25 IF '+$GET(BLRDFN)
- DO ERR^BLRAGUT("BLRAG06: Invalid patient.")
- QUIT
- +26 IF '+$GET(DUZ)
- DO ERR^BLRAGUT("BLRAG06: Invalid user defined.")
- QUIT
- +27 ;
- +28 ;get user name
- SET BLRUSERN=$$GET1^DIQ(200,DUZ_",",.01)
- +29 ;get patient confirmation flag
- SET BLRPTCF=$$PTC^BLRAGUT()
- +30 SET BLRI=BLRI+1
- SET ^TMP("BLRAG",$JOB,BLRI)=BLRDFN_U_DUZ_U_BLRUSERN_U_BLRPTCF
- +31 KILL AGINS
- +32 SET DFN=BLRDFN
- +33 DO ^AGINS
- +34 SET BLRINSI=""
- FOR
- SET BLRINSI=$ORDER(AGINS(BLRINSI))
- IF BLRINSI=""
- QUIT
- Begin DoDot:1
- +35 SET BLRINSD=AGINS(BLRINSI)
- +36 ;S BLRINS=BLRINS_$S(BLRINS'="":"|",1:"")_$P(BLRINSD,U,1)_":"_$P(BLRINSD,U,2)_":"_$P(BLRINSD,U,9)_":"_$P(BLRINSD,U,6)
- +37 SET BLRI=BLRI+1
- SET ^TMP("BLRAG",$JOB,BLRI)=BLRINSD
- End DoDot:1
- +38 ; 0 1 2 3 4
- +39 SET ^TMP("BLRAG",$JOB,0)="T00020DFN^T00020DEFAULT_USER_IEN^T00020DEFAULT_USER_NAME^T00020PT_CONFIRM^T00400INSURANCE_DATA"
- +40 QUIT
- +41 ;
- NP(BLRY,BLRPN) ;EP BLR USER LOOKUP remote procedure
- +1 ; return entries from the NEW PERSON table 200 that are 'active'
- +2 ;INPUT:
- +3 ; BLRPN = text representing partial name for NEW PERSON lookup; must be at least 3 characters
- +4 ;RETURN:
- +5 ; Global array containing entries from the NEW PERSON file 200.
- +6 ; NEW_PERSON_IEN^NAME
- +7 NEW BLRC,BLRN,BLRI,BLRNPS
- +8 ;
- +9 DO ^XBKVAR
- SET X="ERROR^BLRAGUT"
- SET @^%ZOSF("TRAP")
- +10 SET BLRI=0
- +11 KILL ^TMP("BLRAG",$JOB)
- +12 SET BLRY="^TMP(""BLRAG"","_$JOB_")"
- +13 SET ^TMP("BLRAG",$JOB,0)="ERROR_ID"
- +14 IF $LENGTH($GET(BLRPN))<3
- DO ERR^BLRAGUT("BLRAG06: User name lookup requires at least 3 characters.")
- QUIT
- +15 SET BLRN=$$PREP(BLRPN)
- FOR
- SET BLRN=$ORDER(^VA(200,"B",BLRN))
- IF BLRN=""
- QUIT
- IF BLRPN'[$EXTRACT(BLRN,1,$LENGTH(BLRPN))
- QUIT
- Begin DoDot:1
- +16 SET BLRC=$ORDER(^VA(200,"B",BLRN,""))
- +17 SET BLRNPS=$GET(^VA(200,BLRC,"PS"))
- +18 IF ($PIECE(BLRNPS,U,4)="")
- Begin DoDot:2
- +19 SET BLRI=BLRI+1
- SET ^TMP("BLRAG",$JOB,BLRI)=BLRC_U_BLRN
- End DoDot:2
- End DoDot:1
- +20 SET ^TMP("BLRAG",$JOB,0)="T00020NEW_PERSON_IEN^T00020NAME"
- +21 QUIT
- +22 ;
- PREP(NAME) ;prep input for partial name lookup - decrement last char of name for $O; up-shift all alpha characters
- +1 NEW BLRL
- +2 IF $GET(NAME)=""
- QUIT -1
- +3 SET NAME=$$UPS(NAME)
- +4 IF $EXTRACT(NAME,$LENGTH(NAME))'?1A
- QUIT NAME
- +5 SET BLRL=$EXTRACT(NAME,$LENGTH(NAME))
- +6 SET BLRL=$ASCII(BLRL)-1
- +7 QUIT $EXTRACT(NAME,1,$LENGTH(NAME)-1)_$CHAR(BLRL)_"~"
- +8 ;
- UPS(NAME) ;upshift and check punctuation of input
- +1 NEW BLRDGC,BLRDGI
- +2 FOR BLRDGI=1:1:$LENGTH(NAME)
- SET BLRDGC=$EXTRACT(NAME,BLRDGI)
- IF $$FC1(.BLRDGC,1)
- Begin DoDot:1
- +3 SET NAME=$EXTRACT(NAME,0,BLRDGI-1)_BLRDGC_$EXTRACT(NAME,BLRDGI+1,999)
- +4 QUIT
- End DoDot:1
- +5 QUIT NAME
- +6 ;
- FC1(DGC,DGCOMA) ;Transform single character
- +1 ;Input: DGC=character to transform (pass by reference)
- +2 ; DGCOMA=comma indicator
- +3 ;Output: 1 if value is changed, 0 otherwise
- +4 ;
- +5 SET DGC=$EXTRACT(DGC)
- IF '$LENGTH(DGC)
- QUIT 0
- +6 ;See if comma stays
- +7 IF DGCOMA'=3
- IF DGC?1","
- QUIT 0
- +8 ;Retain uppercase, numeric, hyphen, apostrophe and space
- +9 IF DGC?1U!(DGC?1N)!(DGC?1"-")!(DGC?1"'")!(DGC?1" ")
- QUIT 0
- +10 ;Retain parenthesis, bracket and brace characters
- +11 IF DGC?1"("!(DGC?1")")!(DGC?1"[")!(DGC?1"]")!(DGC?1"{")!(DGC?1"}")
- QUIT 0
- +12 ;Transform lowercase to uppercase
- +13 IF DGC?1L
- SET DGC=$CHAR($ASCII(DGC)-32)
- QUIT 1
- +14 ;Set all other characters to space
- +15 SET DGC=" "
- QUIT 1
