BPSUTIL1 ;BHAM ISC/SS - General Utility functions ;08/01/2006
;;1.0;E CLAIMS MGMT ENGINE;**5**;JUN 2004;Build 45
;;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
;Function to return field data from DRUG file (#50)
; Parameters
; BPSIEN50 - IEN of DRUG FILE #50
; BPSFLDN - Field Number(s) (like .01)
; BPSEXIN - Specifies internal or external value of returned field
; - optional, defaults to "I"
; BPSARR50 - Array to return value(s). Optional. Pass by reference.
; See EN^DIQ documentation for variable DIQ
;
; Function returns field data if one field is specified. If
; multiple fields, the function will return "" and the field
; values are returned in BPSARR50
; Example: W $$DRUGDIE^BPSUTIL1(134,25,"E",.ARR)
DRUGDIE(BPSIEN50,BPSFLDN,BPSEXIN,BPSARR50) ; Return field values for Drug file
I $G(BPSIEN50)=""!($G(BPSFLDN)="") Q ""
N DIQ,PSSDIY
N BPSDIQ
I $G(BPSEXIN)'="E" S BPSEXIN="I"
S BPSDIQ="BPSARR50",BPSDIQ(0)=BPSEXIN
D EN^PSSDI(50,"BPS",50,.BPSFLDN,.BPSIEN50,.BPSDIQ)
Q $G(BPSARR50(50,BPSIEN50,BPSFLDN,BPSEXIN))
;
;Function to do lookup on DRUG file (#50)
; Paramters
; BPSDIC - Setup per fileman documentation for call to ^DIC
;
; Returns variables as documented for call to ^DIC except X
; will not be returned.
DRUGDIC(BPSDIC) ; Look up on DRUG FILE (#50)
I '$G(BPSDIC) Q
N PSSDIY
D DIC^PSSDI(50,"BPS",.BPSDIC)
Q
;/*
;Subroutine to return values from MULTIPLE fields of file #52
;DBIA 4858
;input:
; IEN - ien of file #52
; BPSFLDN - one or more fields, for example ".01;2;5"
; BPSRET - contains a name for a local array to return results,
; Note: the name of the array should't be "BPSRET" otherwise it will
; be "newed" since the parameter has the same name
; BPFORMAT -
; "E" for external format
; "I" - internal
; "N" - do not return nulls
; default is "E"
;output:
; result will be put into array with the name specified by BPSRET
; examples:
;D RXAPI^BPSUTIL1(504733,".01;1;6","ARR","IE")
;ZW ARR
;ARR(52,504733,.01,"E")=100004099
;ARR(52,504733,.01,"I")=100004099
;ARR(52,504733,1,"E")="JUL 21, 2006"
;ARR(52,504733,1,"I")=3060721
;ARR(52,504733,6,"E")="ALBUMIN 25% 50ML"
;ARR(52,504733,6,"I")=134
RXAPI(BPSIEN52,BPSFLDN,BPSRET,BPFORMAT) ;*/
I ($G(BPSIEN52)="")!($G(BPSFLDN)="")!($G(BPSRET)="") Q
N DIQ,DIC,X,Y,D0,PSODIY
N I,J,C,DA,DRS,DIL,DI,DIQ1
N BPSDIQ
S BPSDIQ=$NA(@BPSRET)
S BPSDIQ(0)=$S($G(BPFORMAT)="":"E",1:BPFORMAT)
D DIQ^PSODI(52,52,.BPSFLDN,.BPSIEN52,.BPSDIQ) ;DBIA 4858
Q
;
;/*
;Function to return a value for a SINGLE field of file #52
;DBIA 4858
;input:
; BPSIEN52 - ien of file #52
; BPSFLDN - one single field, for example ".01"
; BPFORMAT - optional parameter,
; "E" for external format
; "I" - internal
; "N" - do not return nulls
; default is "E"
;output:
; returns a field value or null (empty string)
; examples:
;W $$RXAPI1^BPSUTIL1(504733,6,"E")
;ALBUMIN 25% 50ML
;W $$RXAPI1^BPSUTIL1(504733,6,"I")
;134
RXAPI1(BPSIEN52,BPSFLDN,BPFORMAT) ;*/
I ($G(BPSIEN52)="")!($G(BPSFLDN)="") Q ""
N DIQ,DIC,BPSARR,X,Y,D0,PSODIY
N I,J,C,DA,DRS,DIL,DI,DIQ1
N BPSDIQ
S BPSDIQ="BPSARR"
S BPSDIQ(0)=$S($G(BPFORMAT)="":"E",1:BPFORMAT)
D DIQ^PSODI(52,52,.BPSFLDN,.BPSIEN52,.BPSDIQ) ;DBIA 4858
Q $S(BPSDIQ(0)="N":$G(BPSARR(52,BPSIEN52,BPSFLDN)),1:$G(BPSARR(52,BPSIEN52,BPSFLDN,BPSDIQ(0))))
;
;/*
;Subroutine to return values from MULTIPLE fields of a subfile of the file #52
;DBIA 4858
;input:
; BPSIEN52 - ien of file #52
; BPSFLD52 - field # that relates to this subfile
; BPSUBFNO - subfile number (like 52.052311)
; BPSUBIEN - ien of the subfile record you're interested in
; BPSUBFLD - one or more fields, for example ".01;2;5"
; BPSRET - name for a local array to return results
; BPFORMAT - optional parameter.
; "E" for external format
; "I" - internal
; "N" - do not return nulls
; default is "E"
;output:
; returns results in array BPSRET in the form:
; BPSRET (BPSUBFNO, BPSUBIEN, BPSUBFLD,BPFORMAT)=value
;
;example for (#52311) ICD DIAGNOSIS subfile
;D RXSUBF^BPSUTIL1(504740,52311,52.052311,1,".01;1;2","ARR","I")
;ZW ARR
;ARR(52.052311,1,.01,"I")=816
;ARR(52.052311,1,1,"I")=1
;ARR(52.052311,1,2,"I")=1
;
RXSUBF(BPSIEN52,BPSFLD52,BPSUBFNO,BPSUBIEN,BPSUBFLD,BPSRET,BPFORMAT) ;
I ($G(BPSIEN52)="")!($G(BPSFLD52)="")!($G(BPSUBFNO)="")!($G(BPSUBIEN)="")!($G(BPSUBFLD)="")!($G(BPSRET)="") Q
N DIQ,DIC,DA,DR,X,Y,D0,PSODIY
N I,J,C,DA,DRS,DIL,DI,DIQ1
N BPSDIC,BPSDR,BPSDA,BPSDIQ
S BPSDIC=52 ;main file #52
S BPSDA=BPSIEN52 ;ien in main file #52
S BPSDA(BPSUBFNO)=BPSUBIEN ;ien in subfile
S BPSDR=BPSFLD52 ;field# of the subfile in the main file
S BPSDR(BPSUBFNO)=BPSUBFLD ;field# in the subfile that we need to get a value for
S BPSDIQ=$NA(@BPSRET) ;output array
S BPSDIQ(0)=$S($G(BPFORMAT)="":"E",1:BPFORMAT)
D DIQ^PSODI(52,.BPSDIC,.BPSDR,.BPSDA,.BPSDIQ) ;DBIA 4858
Q
;
;/*
;Function to return a value for a SINGLE field of a subfile of the file #52
;DBIA 4858
;input:
; BPSIEN52 - ien of file #52
; BPSFLD52 - field # that relates to this subfile
; BPSUBFNO - subfile number (like 52.052311)
; BPSUBIEN - ien of the subfile record you're interested in
; BPSUBFLD - one single field, for example ".01"
; BPFORMAT - optional parameter,
; "E" for external format
; "I" - internal
; "N" - do not return nulls
; default is "E"
;output:
; returns a field value or null (empty string)
;
;example for (#52311) ICD DIAGNOSIS subfile
;W $$RXSUBF1^BPSUTIL1(504740,52311,52.052311,1,1,"I")
;1
;W $$RXSUBF1^BPSUTIL1(504740,52311,52.052311,1,.01,"E")
;239.1
;
RXSUBF1(BPSIEN52,BPSFLD52,BPSUBFNO,BPSUBIEN,BPSUBFLD,BPFORMAT) ;*/
I ($G(BPSIEN52)="")!($G(BPSFLD52)="")!($G(BPSUBFNO)="")!($G(BPSUBIEN)="")!($G(BPSUBFLD)="") Q ""
N DIQ,DIC,BPSARR,DA,DR,X,Y,D0,PSODIY
N I,J,C,DRS,DIL,DI,DIQ1
N BPSDIC,BPSDA,BPSDR
S BPSDIC=52 ;main file #52
S BPSDA=BPSIEN52 ;ien in main file #52
S BPSDA(BPSUBFNO)=BPSUBIEN ;ien in subfile
S BPSDR=BPSFLD52 ;field# of the subfile in the main file
S BPSDR(BPSUBFNO)=BPSUBFLD ;field# in the subfile that we need to get a value for
S BPSDIQ="BPSARR" ;output array
S BPSDIQ(0)=$S($G(BPFORMAT)="":"E",1:BPFORMAT)
D DIQ^PSODI(52,.BPSDIC,.BPSDR,.BPSDA,.BPSDIQ) ;DBIA 4858
Q $S(BPSDIQ(0)="N":$G(BPSARR(BPSUBFNO,BPSUBIEN,BPSUBFLD)),1:$G(BPSARR(BPSUBFNO,BPSUBIEN,BPSUBFLD,BPSDIQ(0))))
;
;
;Function to return a value for a single field of subfile #52.1
;DBIA 4858
;input:
; BPSIEN52 - ien of file #52
; REFIEN - refill ien of subfile #52.1
; BPSFLDN - one single field, for example ".01"
; BPFORMAT - (optional)
; "E" for external format
; "I" - internal
; "N" - do not return nulls
; default is "E"
;output:
; returns a field value or null (empty string)
; examples:
;W $$REFAPI1^BPSUTIL1(401777,1,.01,"I")
;3000526
REFAPI1(BPSIEN52,REFIEN,BPSFLDN,BPFORMAT) ;
I ($G(BPSIEN52)="")!($G(REFIEN)="")!($G(BPSFLDN)="") Q ""
Q $$RXSUBF1(BPSIEN52,52,52.1,REFIEN,BPSFLDN,$G(BPFORMAT))
;
;
;/**
;DBIA 4858
;prompts for RX selection
;input:
; BPSPROM - prompt message
; BPSDFLT - default value for the prompt (optional parameter)
;output:
; returns selection (IEN of file #52)
; OR -1 when timeout and/or uparrow
; OR -2 when incorrect parameters
;Example:
;W $$PROMPTRX^BPSUTIL1("Select RX:",100003784)
;Select RX:: 100003784// ??
; Choose from:
;200168 200081A MYLANTA II LIQUID 5 OZ
;200291 300110B IBUPROFEN 600MG
PROMPTRX(BPSPROM,BPSDFLT) ;*/
N Y,X,DUOUT,DTOUT,DIROUT,DIC,PSODIY,DILN,I
N BPSDIC
S BPSDIC=52,X=""
S BPSDIC(0)="AEMNQ"
S:$L($G(BPSDFLT))>0 BPSDIC("B")=BPSDFLT
S:$G(BPSPROM)]"" BPSDIC("A")=BPSPROM_": "
D DIC^PSODI(52,.BPSDIC,X) ;DBIA 4858
I (Y=-1)!$D(DUOUT)!$D(DTOUT) Q -1
Q $P(Y,U)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSUTIL1 8003 printed Oct 16, 2024@17:54:25 Page 2
BPSUTIL1 ;BHAM ISC/SS - General Utility functions ;08/01/2006
+1 ;;1.0;E CLAIMS MGMT ENGINE;**5**;JUN 2004;Build 45
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;Function to return field data from DRUG file (#50)
+6 ; Parameters
+7 ; BPSIEN50 - IEN of DRUG FILE #50
+8 ; BPSFLDN - Field Number(s) (like .01)
+9 ; BPSEXIN - Specifies internal or external value of returned field
+10 ; - optional, defaults to "I"
+11 ; BPSARR50 - Array to return value(s). Optional. Pass by reference.
+12 ; See EN^DIQ documentation for variable DIQ
+13 ;
+14 ; Function returns field data if one field is specified. If
+15 ; multiple fields, the function will return "" and the field
+16 ; values are returned in BPSARR50
+17 ; Example: W $$DRUGDIE^BPSUTIL1(134,25,"E",.ARR)
DRUGDIE(BPSIEN50,BPSFLDN,BPSEXIN,BPSARR50) ; Return field values for Drug file
+1 IF $GET(BPSIEN50)=""!($GET(BPSFLDN)="")
QUIT ""
+2 NEW DIQ,PSSDIY
+3 NEW BPSDIQ
+4 IF $GET(BPSEXIN)'="E"
SET BPSEXIN="I"
+5 SET BPSDIQ="BPSARR50"
SET BPSDIQ(0)=BPSEXIN
+6 DO EN^PSSDI(50,"BPS",50,.BPSFLDN,.BPSIEN50,.BPSDIQ)
+7 QUIT $GET(BPSARR50(50,BPSIEN50,BPSFLDN,BPSEXIN))
+8 ;
+9 ;Function to do lookup on DRUG file (#50)
+10 ; Paramters
+11 ; BPSDIC - Setup per fileman documentation for call to ^DIC
+12 ;
+13 ; Returns variables as documented for call to ^DIC except X
+14 ; will not be returned.
DRUGDIC(BPSDIC) ; Look up on DRUG FILE (#50)
+1 IF '$GET(BPSDIC)
QUIT
+2 NEW PSSDIY
+3 DO DIC^PSSDI(50,"BPS",.BPSDIC)
+4 QUIT
+5 ;/*
+6 ;Subroutine to return values from MULTIPLE fields of file #52
+7 ;DBIA 4858
+8 ;input:
+9 ; IEN - ien of file #52
+10 ; BPSFLDN - one or more fields, for example ".01;2;5"
+11 ; BPSRET - contains a name for a local array to return results,
+12 ; Note: the name of the array should't be "BPSRET" otherwise it will
+13 ; be "newed" since the parameter has the same name
+14 ; BPFORMAT -
+15 ; "E" for external format
+16 ; "I" - internal
+17 ; "N" - do not return nulls
+18 ; default is "E"
+19 ;output:
+20 ; result will be put into array with the name specified by BPSRET
+21 ; examples:
+22 ;D RXAPI^BPSUTIL1(504733,".01;1;6","ARR","IE")
+23 ;ZW ARR
+24 ;ARR(52,504733,.01,"E")=100004099
+25 ;ARR(52,504733,.01,"I")=100004099
+26 ;ARR(52,504733,1,"E")="JUL 21, 2006"
+27 ;ARR(52,504733,1,"I")=3060721
+28 ;ARR(52,504733,6,"E")="ALBUMIN 25% 50ML"
+29 ;ARR(52,504733,6,"I")=134
RXAPI(BPSIEN52,BPSFLDN,BPSRET,BPFORMAT) ;*/
+1 IF ($GET(BPSIEN52)="")!($GET(BPSFLDN)="")!($GET(BPSRET)="")
QUIT
+2 NEW DIQ,DIC,X,Y,D0,PSODIY
+3 NEW I,J,C,DA,DRS,DIL,DI,DIQ1
+4 NEW BPSDIQ
+5 SET BPSDIQ=$NAME(@BPSRET)
+6 SET BPSDIQ(0)=$SELECT($GET(BPFORMAT)="":"E",1:BPFORMAT)
+7 ;DBIA 4858
DO DIQ^PSODI(52,52,.BPSFLDN,.BPSIEN52,.BPSDIQ)
+8 QUIT
+9 ;
+10 ;/*
+11 ;Function to return a value for a SINGLE field of file #52
+12 ;DBIA 4858
+13 ;input:
+14 ; BPSIEN52 - ien of file #52
+15 ; BPSFLDN - one single field, for example ".01"
+16 ; BPFORMAT - optional parameter,
+17 ; "E" for external format
+18 ; "I" - internal
+19 ; "N" - do not return nulls
+20 ; default is "E"
+21 ;output:
+22 ; returns a field value or null (empty string)
+23 ; examples:
+24 ;W $$RXAPI1^BPSUTIL1(504733,6,"E")
+25 ;ALBUMIN 25% 50ML
+26 ;W $$RXAPI1^BPSUTIL1(504733,6,"I")
+27 ;134
RXAPI1(BPSIEN52,BPSFLDN,BPFORMAT) ;*/
+1 IF ($GET(BPSIEN52)="")!($GET(BPSFLDN)="")
QUIT ""
+2 NEW DIQ,DIC,BPSARR,X,Y,D0,PSODIY
+3 NEW I,J,C,DA,DRS,DIL,DI,DIQ1
+4 NEW BPSDIQ
+5 SET BPSDIQ="BPSARR"
+6 SET BPSDIQ(0)=$SELECT($GET(BPFORMAT)="":"E",1:BPFORMAT)
+7 ;DBIA 4858
DO DIQ^PSODI(52,52,.BPSFLDN,.BPSIEN52,.BPSDIQ)
+8 QUIT $SELECT(BPSDIQ(0)="N":$GET(BPSARR(52,BPSIEN52,BPSFLDN)),1:$GET(BPSARR(52,BPSIEN52,BPSFLDN,BPSDIQ(0))))
+9 ;
+10 ;/*
+11 ;Subroutine to return values from MULTIPLE fields of a subfile of the file #52
+12 ;DBIA 4858
+13 ;input:
+14 ; BPSIEN52 - ien of file #52
+15 ; BPSFLD52 - field # that relates to this subfile
+16 ; BPSUBFNO - subfile number (like 52.052311)
+17 ; BPSUBIEN - ien of the subfile record you're interested in
+18 ; BPSUBFLD - one or more fields, for example ".01;2;5"
+19 ; BPSRET - name for a local array to return results
+20 ; BPFORMAT - optional parameter.
+21 ; "E" for external format
+22 ; "I" - internal
+23 ; "N" - do not return nulls
+24 ; default is "E"
+25 ;output:
+26 ; returns results in array BPSRET in the form:
+27 ; BPSRET (BPSUBFNO, BPSUBIEN, BPSUBFLD,BPFORMAT)=value
+28 ;
+29 ;example for (#52311) ICD DIAGNOSIS subfile
+30 ;D RXSUBF^BPSUTIL1(504740,52311,52.052311,1,".01;1;2","ARR","I")
+31 ;ZW ARR
+32 ;ARR(52.052311,1,.01,"I")=816
+33 ;ARR(52.052311,1,1,"I")=1
+34 ;ARR(52.052311,1,2,"I")=1
+35 ;
RXSUBF(BPSIEN52,BPSFLD52,BPSUBFNO,BPSUBIEN,BPSUBFLD,BPSRET,BPFORMAT) ;
+1 IF ($GET(BPSIEN52)="")!($GET(BPSFLD52)="")!($GET(BPSUBFNO)="")!($GET(BPSUBIEN)="")!($GET(BPSUBFLD)="")!($GET(BPSRET)="")
QUIT
+2 NEW DIQ,DIC,DA,DR,X,Y,D0,PSODIY
+3 NEW I,J,C,DA,DRS,DIL,DI,DIQ1
+4 NEW BPSDIC,BPSDR,BPSDA,BPSDIQ
+5 ;main file #52
SET BPSDIC=52
+6 ;ien in main file #52
SET BPSDA=BPSIEN52
+7 ;ien in subfile
SET BPSDA(BPSUBFNO)=BPSUBIEN
+8 ;field# of the subfile in the main file
SET BPSDR=BPSFLD52
+9 ;field# in the subfile that we need to get a value for
SET BPSDR(BPSUBFNO)=BPSUBFLD
+10 ;output array
SET BPSDIQ=$NAME(@BPSRET)
+11 SET BPSDIQ(0)=$SELECT($GET(BPFORMAT)="":"E",1:BPFORMAT)
+12 ;DBIA 4858
DO DIQ^PSODI(52,.BPSDIC,.BPSDR,.BPSDA,.BPSDIQ)
+13 QUIT
+14 ;
+15 ;/*
+16 ;Function to return a value for a SINGLE field of a subfile of the file #52
+17 ;DBIA 4858
+18 ;input:
+19 ; BPSIEN52 - ien of file #52
+20 ; BPSFLD52 - field # that relates to this subfile
+21 ; BPSUBFNO - subfile number (like 52.052311)
+22 ; BPSUBIEN - ien of the subfile record you're interested in
+23 ; BPSUBFLD - one single field, for example ".01"
+24 ; BPFORMAT - optional parameter,
+25 ; "E" for external format
+26 ; "I" - internal
+27 ; "N" - do not return nulls
+28 ; default is "E"
+29 ;output:
+30 ; returns a field value or null (empty string)
+31 ;
+32 ;example for (#52311) ICD DIAGNOSIS subfile
+33 ;W $$RXSUBF1^BPSUTIL1(504740,52311,52.052311,1,1,"I")
+34 ;1
+35 ;W $$RXSUBF1^BPSUTIL1(504740,52311,52.052311,1,.01,"E")
+36 ;239.1
+37 ;
RXSUBF1(BPSIEN52,BPSFLD52,BPSUBFNO,BPSUBIEN,BPSUBFLD,BPFORMAT) ;*/
+1 IF ($GET(BPSIEN52)="")!($GET(BPSFLD52)="")!($GET(BPSUBFNO)="")!($GET(BPSUBIEN)="")!($GET(BPSUBFLD)="")
QUIT ""
+2 NEW DIQ,DIC,BPSARR,DA,DR,X,Y,D0,PSODIY
+3 NEW I,J,C,DRS,DIL,DI,DIQ1
+4 NEW BPSDIC,BPSDA,BPSDR
+5 ;main file #52
SET BPSDIC=52
+6 ;ien in main file #52
SET BPSDA=BPSIEN52
+7 ;ien in subfile
SET BPSDA(BPSUBFNO)=BPSUBIEN
+8 ;field# of the subfile in the main file
SET BPSDR=BPSFLD52
+9 ;field# in the subfile that we need to get a value for
SET BPSDR(BPSUBFNO)=BPSUBFLD
+10 ;output array
SET BPSDIQ="BPSARR"
+11 SET BPSDIQ(0)=$SELECT($GET(BPFORMAT)="":"E",1:BPFORMAT)
+12 ;DBIA 4858
DO DIQ^PSODI(52,.BPSDIC,.BPSDR,.BPSDA,.BPSDIQ)
+13 QUIT $SELECT(BPSDIQ(0)="N":$GET(BPSARR(BPSUBFNO,BPSUBIEN,BPSUBFLD)),1:$GET(BPSARR(BPSUBFNO,BPSUBIEN,BPSUBFLD,BPSDIQ(0))))
+14 ;
+15 ;
+16 ;Function to return a value for a single field of subfile #52.1
+17 ;DBIA 4858
+18 ;input:
+19 ; BPSIEN52 - ien of file #52
+20 ; REFIEN - refill ien of subfile #52.1
+21 ; BPSFLDN - one single field, for example ".01"
+22 ; BPFORMAT - (optional)
+23 ; "E" for external format
+24 ; "I" - internal
+25 ; "N" - do not return nulls
+26 ; default is "E"
+27 ;output:
+28 ; returns a field value or null (empty string)
+29 ; examples:
+30 ;W $$REFAPI1^BPSUTIL1(401777,1,.01,"I")
+31 ;3000526
REFAPI1(BPSIEN52,REFIEN,BPSFLDN,BPFORMAT) ;
+1 IF ($GET(BPSIEN52)="")!($GET(REFIEN)="")!($GET(BPSFLDN)="")
QUIT ""
+2 QUIT $$RXSUBF1(BPSIEN52,52,52.1,REFIEN,BPSFLDN,$GET(BPFORMAT))
+3 ;
+4 ;
+5 ;/**
+6 ;DBIA 4858
+7 ;prompts for RX selection
+8 ;input:
+9 ; BPSPROM - prompt message
+10 ; BPSDFLT - default value for the prompt (optional parameter)
+11 ;output:
+12 ; returns selection (IEN of file #52)
+13 ; OR -1 when timeout and/or uparrow
+14 ; OR -2 when incorrect parameters
+15 ;Example:
+16 ;W $$PROMPTRX^BPSUTIL1("Select RX:",100003784)
+17 ;Select RX:: 100003784// ??
+18 ; Choose from:
+19 ;200168 200081A MYLANTA II LIQUID 5 OZ
+20 ;200291 300110B IBUPROFEN 600MG
PROMPTRX(BPSPROM,BPSDFLT) ;*/
+1 NEW Y,X,DUOUT,DTOUT,DIROUT,DIC,PSODIY,DILN,I
+2 NEW BPSDIC
+3 SET BPSDIC=52
SET X=""
+4 SET BPSDIC(0)="AEMNQ"
+5 if $LENGTH($GET(BPSDFLT))>0
SET BPSDIC("B")=BPSDFLT
+6 if $GET(BPSPROM)]""
SET BPSDIC("A")=BPSPROM_": "
+7 ;DBIA 4858
DO DIC^PSODI(52,.BPSDIC,X)
+8 IF (Y=-1)!$DATA(DUOUT)!$DATA(DTOUT)
QUIT -1
+9 QUIT $PIECE(Y,U)
+10 ;
