Index: WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBUTL1.m
===================================================================
--- WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBUTL1.m	(revision 613)
+++ WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBUTL1.m	(revision 623)
@@ -1,208 +1,207 @@
-ALPBUTL1	;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES  ;01/01/03
-	;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
-	;;Per VHA Directive 2004-038, this routine should not be modified.
-	;
-	; Reference/IA
-	; INP^VADPT/10061
-	; DIC(42/10039
-	; DIC(42/2440
-	;
-ERRBLD(SEG,MSG,ERR)	; build an error array for non-FileMan-related errors...
-	; SEG = HL7 segment name
-	; MSG = a message that will be used in the error text portion of the array (optional -- if not passed, the
-	;       default will be used)
-	; ERR = array passed by reference in which error will be returned
-	; note:  code 999 is a code indicating a non-FileMan error for filing the error message in file 53.71
-	S ERR("DIERR")=1
-	S ERR("DIERR",1)=999
-	S ERR("DIERR",1,"TEXT",1)=$S($G(MSG)'="":MSG,1:"Invalid parameter passed to "_SEG_" module in routine ALPBHL1U")
-	Q
-	;
-ERRLOG(IEN,OIEN,MSGREC,SEGNAME,SEGDATA,ERRTEXT)	; log filing errors...
-	; this module logs error data in the BCMA BACKUP PARAMETERS file (53.71).  These
-	; errors usually occur as the result of missing or bad data passed to one of the
-	; File Manager DBS calls used by this package.
-	; 
-	; IEN       = the patient's record number in file 53.7
-	; OIEN      = the order number's sub-file record number in file 53.7
-	; MSGREC    = the HL7 message's record number in file 772
-	; SEGNAME   = the HL7 segment associated with the error (optional)
-	; SEGDATA   = the HL7 segment's data (optional)
-	; ERRTEXT   = an array passed by reference which contains the error
-	;             code (numeric) and the error text to be filed.  It is
-	;             expected that this is usually the error array returned
-	;             from a FileMan DBS call, so the format is specific:
-	;
-	;             ERRTEXT("DIERR",n)=error code (numeric)
-	;             ERRTEXT("DIERR",n,"TEXT",1)=first line of error text
-	;             ERRTEXT("DIERR",n,"TEXT",2)=second line of error text
-	;             ERRTEXT("DIERR",n,"TEXT",n)=last line of error text
-	;
-	;             However, any error message can be passed to this module
-	;             as long as the above format is used.
-	N ALPBCODE,ALPBFERR,ALPBFILE,ALPBLOGD,ALPBN1,ALPBN2,ALPBPIEN,ALPBTEXT,ALPBX
-	S ALPBLOGD=$$NOW^XLFDT()
-	S ALPBPIEN=+$O(^ALPB(53.71,0))
-	I ALPBPIEN=0 D
-	.S X="ONE"
-	.S DIC="^ALPB(53.71,"
-	.S DIC(0)="LZ"
-	.S DIC("DR")="1///^S X=3"
-	.S DINUM=1
-	.S DLAYGO=53.71
-	.D FILE^DICN K DIC
-	.S ALPBPIEN=+Y
-	I ALPBPIEN'>0 Q
-	S ALPBN1=+$O(^ALPB(53.71,ALPBPIEN,1," "),-1)+1
-	S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",.01)=ALPBLOGD
-	S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",1)=+$G(IEN)
-	S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",2)=+$G(OIEN)
-	S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3)=+$G(MSGREC)
-	S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.1)=$G(SEGNAME)
-	S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.2)=$G(SEGDATA)
-	D UPDATE^DIE("","ALPBFILE","ALPBN1","ALPBFERR")
-	K ALPBFERR,ALPBFILE
-	S ALPBX=0
-	F  S ALPBX=$O(ERRTEXT("DIERR",ALPBX)) Q:'ALPBX  D
-	.S ALPBCODE=ERRTEXT("DIERR",ALPBX)
-	.; file the error code...
-	.S ALPBN2=+$O(^ALPB(53.71,ALPBPIEN,1,ALPBN1,2," "),-1)+1
-	.S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",.01)=ALPBCODE
-	.D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR")
-	.K ALPBFERR,ALPBFILE
-	.; file the error text...
-	.M ALPBTEXT=ERRTEXT("DIERR",ALPBX,"TEXT")
-	.D WP^DIE(53.7135,ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1,"","ALPBTEXT","ALPBFERR")
-	.;S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1)=ALPBTEXT
-	.;D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR")
-	.K ALPBCODE,ALPBFERR,ALPBFILE,ALPBN2,ALPBTEXT
-	Q
-	;
-CLEAN(IEN)	; check error log records to see if the patients' whose records
-	; are noted still exist in file 53.7.  if not, delete the error log
-	; record(s) in file 53.71...
-	; IEN = patient record number in file 53.7
-	; Note:  this function is also called from DELPT^ALPBUTL when a patient's
-	; record is deleted (as a result of a discharge action) from 53.7.
-	;
-	N ALPBX,ALPBY,DA,DIK,X,Y
-	; patient still has record in 53.7?  if so, quit...
-	I $G(^ALPB(53.7,IEN,0))'="" Q
-	S ALPBX=0
-	F  S ALPBX=$O(^ALPB(53.71,"C",IEN,ALPBX)) Q:'ALPBX  D
-	.S ALPBY=0
-	.F  S ALPBY=$O(^ALPB(53.71,"C",IEN,ALPBX,ALPBY)) Q:'ALPBY  D
-	..S DA=ALPBY
-	..S DA(1)=ALPBX
-	..S DIK="^ALPB(53.71,"_DA(1)_",1,"
-	..D ^DIK
-	..K DA,DIK
-	.K ALPBY
-	K ALPBX
-	Q
-	;
-DELERR(ERRIEN)	; delete an error log entry from file 53.71...
-	; ERRIEN = error log entry's internal record number
-	N ALPBPARM,DA,DIK,X,Y
-	S ALPBPARM=+$O(^ALPB(53.71,0))
-	I ALPBPARM'>0 Q
-	S DA=ERRIEN
-	S DA(1)=ALPBPARM
-	S DIK="^ALPB(53.71,"_DA(1)_",1,"
-	D ^DIK
-	Q
-	;
-PTLIST(LTYPE,RESULTS)	; get list of patients in file 53.7...
-	; LTYPE   = passed = "ALL" to list all patients or
-	;                  = <wardname> to list patients on a selected ward
-	; RESULTS = an array passed by reference in which data will be returned
-	N ALPBDATA,ALPBIEN,ALPBPTN,ALPBX
-	I $G(LTYPE)="" S LTYPE="ALL"
-	S ALPBX=0
-	I LTYPE="ALL" D
-	.S ALPBPTN=""
-	.F  S ALPBPTN=$O(^ALPB(53.7,"B",ALPBPTN)) Q:ALPBPTN=""  D
-	..S ALPBIEN=0
-	..F  S ALPBIEN=$O(^ALPB(53.7,"B",ALPBPTN,ALPBIEN)) Q:'ALPBIEN  D
-	...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0))
-	...I ALPBDATA="" K ALPBDATA Q
-	...S ALPBX=ALPBX+1
-	...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7)
-	...K ALPBDATA
-	..K ALPBIEN
-	.K ALPBPTN
-	I LTYPE'="ALL" D
-	.S ALPBPTN=""
-	.F  S ALPBPTN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN)) Q:ALPBPTN=""  D
-	..S ALPBIEN=0
-	..F  S ALPBIEN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN,ALPBIEN)) Q:'ALPBIEN  D
-	...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0))
-	...I ALPBDATA="" K ALPBDATA Q
-	...S ALPBX=ALPBX+1
-	...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7)
-	...K ALPBDATA
-	..K ALPBIEN
-	.K ALPBPTN
-	Q
-	;
-STAT(ST)	;This will return the value of a status code for pharmacy
-	I $G(ST)="" Q ""
-	I $L($T(@ST)) G @ST
-	Q ""
-IP	Q "pending"
-CM	Q "finished/verified by pharmacist(active)"
-DC	Q "discontinued"
-RP	Q "replaced"
-HD	Q "on hold"
-ZE	Q "expired"
-ZS	Q "suspended(active)"
-ZU	Q "un-suspended(active)"
-ZX	Q "unreleased"
-ZZ	Q "renewed"
-	;
-STAT2(CODE)	; convert order status code for output...
-	; this function is used primarily by the workstation software
-	; CODE = an order status code
-	; returns printable status code
-	I $G(CODE)="" Q "Unknown"
-	I CODE="IP"!(CODE="ZX") Q "Pending"
-	I CODE="CM"!(CODE="ZU")!(CODE="ZZ") Q "Active"
-	I CODE="HD"!(CODE="ZS") Q "Hold"
-	I CODE="DC"!(CODE="RP")!(CODE="ZE") Q "Expired"
-	Q "Unknown"
-	;
-DIV(DFN,ALPBMDT)	;get the Division for a patient
-	I +$G(DFN)'>0 Q ""
-	N ALPBDIV,ALPWRD,VAIN,VAINDT
-	S:+$G(ALPBMDT)>0 VAINDT=$P(ALPBMDT,".",1)
-	K ALPBMDT
-	D INP^VADPT
-	S ALPWRD=$P($G(VAIN(4)),U,1)
-	Q:+ALPWRD'>0 ""
-	;Check to see if ward is a DOMICILIARY 
-	I $P($G(^DIC(42,ALPWRD,0)),U,3)="D",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "DOM"
-	S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11)
-	Q:+ALPBDIV'>0 ""
-	Q ALPBDIV
-	;
-CNV(A,B,X)	;CONVERT A STRING
-	;This API will take a HL7 segment and convert characters
-	;defined in the input
-	;Example:
-	;Single encoding characters can be converted such as ^ to ~
-	;or multiple encoding characters can be converted such as
-	;  |~^@/ to ^~|/@
-	;A is the string of HL7 encoding characters to be converted
-	;B is the string of HL7 encoding characters to be converted to
-	;X is te message string to be converted
-	I A=""!B=""!X="" Q ""
-	F I=1:1:$L(A) S A(I)=$E(A,I,I),A(I,1)=""
-	F I=1:1:$L(B) S B(I)=$E(B,I,I)
-	S J=0
-	F  S J=$O(A(J)) Q:+J'>0  D
-	. F I=1:1:$L(X) S:$E(X,I,I)=A(J) A(J,1)=A(J,1)_I_U
-	S J=0
-	F  S J=$O(A(J)) Q:+J'>0  D
-	. Q:'$D(A(J,1))!'$D(B(J))
-	. F I=1:1:$L(A(J,1),U) S C=$P(A(J,1),U,I) S:+C>0 $E(X,C,C)=B(J)
-	Q X
+ALPBUTL1 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES  ;01/01/03
+ ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
+ ;
+ ; Reference/IA
+ ; INP^VADPT/10061
+ ; DIC(42/10039
+ ; DIC(42/2440
+ ;
+ERRBLD(SEG,MSG,ERR) ; build an error array for non-FileMan-related errors...
+ ; SEG = HL7 segment name
+ ; MSG = a message that will be used in the error text portion of the array (optional -- if not passed, the
+ ;       default will be used)
+ ; ERR = array passed by reference in which error will be returned
+ ; note:  code 999 is a code indicating a non-FileMan error for filing the error message in file 53.71
+ S ERR("DIERR")=1
+ S ERR("DIERR",1)=999
+ S ERR("DIERR",1,"TEXT",1)=$S($G(MSG)'="":MSG,1:"Invalid parameter passed to "_SEG_" module in routine ALPBHL1U")
+ Q
+ ;
+ERRLOG(IEN,OIEN,MSGREC,SEGNAME,SEGDATA,ERRTEXT) ; log filing errors...
+ ; this module logs error data in the BCMA BACKUP PARAMETERS file (53.71).  These
+ ; errors usually occur as the result of missing or bad data passed to one of the
+ ; File Manager DBS calls used by this package.
+ ; 
+ ; IEN       = the patient's record number in file 53.7
+ ; OIEN      = the order number's sub-file record number in file 53.7
+ ; MSGREC    = the HL7 message's record number in file 772
+ ; SEGNAME   = the HL7 segment associated with the error (optional)
+ ; SEGDATA   = the HL7 segment's data (optional)
+ ; ERRTEXT   = an array passed by reference which contains the error
+ ;             code (numeric) and the error text to be filed.  It is
+ ;             expected that this is usually the error array returned
+ ;             from a FileMan DBS call, so the format is specific:
+ ;
+ ;             ERRTEXT("DIERR",n)=error code (numeric)
+ ;             ERRTEXT("DIERR",n,"TEXT",1)=first line of error text
+ ;             ERRTEXT("DIERR",n,"TEXT",2)=second line of error text
+ ;             ERRTEXT("DIERR",n,"TEXT",n)=last line of error text
+ ;
+ ;             However, any error message can be passed to this module
+ ;             as long as the above format is used.
+ N ALPBCODE,ALPBFERR,ALPBFILE,ALPBLOGD,ALPBN1,ALPBN2,ALPBPIEN,ALPBTEXT,ALPBX
+ S ALPBLOGD=$$NOW^XLFDT()
+ S ALPBPIEN=+$O(^ALPB(53.71,0))
+ I ALPBPIEN=0 D
+ .S X="ONE"
+ .S DIC="^ALPB(53.71,"
+ .S DIC(0)="LZ"
+ .S DIC("DR")="1///^S X=3"
+ .S DINUM=1
+ .S DLAYGO=53.71
+ .D FILE^DICN K DIC
+ .S ALPBPIEN=+Y
+ I ALPBPIEN'>0 Q
+ S ALPBN1=+$O(^ALPB(53.71,ALPBPIEN,1," "),-1)+1
+ S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",.01)=ALPBLOGD
+ S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",1)=+$G(IEN)
+ S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",2)=+$G(OIEN)
+ S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3)=+$G(MSGREC)
+ S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.1)=$G(SEGNAME)
+ S ALPBFILE(53.713,"+"_ALPBN1_","_ALPBPIEN_",",3.2)=$G(SEGDATA)
+ D UPDATE^DIE("","ALPBFILE","ALPBN1","ALPBFERR")
+ K ALPBFERR,ALPBFILE
+ S ALPBX=0
+ F  S ALPBX=$O(ERRTEXT("DIERR",ALPBX)) Q:'ALPBX  D
+ .S ALPBCODE=ERRTEXT("DIERR",ALPBX)
+ .; file the error code...
+ .S ALPBN2=+$O(^ALPB(53.71,ALPBPIEN,1,ALPBN1,2," "),-1)+1
+ .S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",.01)=ALPBCODE
+ .D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR")
+ .K ALPBFERR,ALPBFILE
+ .; file the error text...
+ .M ALPBTEXT=ERRTEXT("DIERR",ALPBX,"TEXT")
+ .D WP^DIE(53.7135,ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1,"","ALPBTEXT","ALPBFERR")
+ .;S ALPBFILE(53.7135,"+"_ALPBN2_","_ALPBN1_","_ALPBPIEN_",",1)=ALPBTEXT
+ .;D UPDATE^DIE("","ALPBFILE","ALPBN2","ALPBFERR")
+ .K ALPBCODE,ALPBFERR,ALPBFILE,ALPBN2,ALPBTEXT
+ Q
+ ;
+CLEAN(IEN) ; check error log records to see if the patients' whose records
+ ; are noted still exist in file 53.7.  if not, delete the error log
+ ; record(s) in file 53.71...
+ ; IEN = patient record number in file 53.7
+ ; Note:  this function is also called from DELPT^ALPBUTL when a patient's
+ ; record is deleted (as a result of a discharge action) from 53.7.
+ ;
+ N ALPBX,ALPBY,DA,DIK,X,Y
+ ; patient still has record in 53.7?  if so, quit...
+ I $G(^ALPB(53.7,IEN,0))'="" Q
+ S ALPBX=0
+ F  S ALPBX=$O(^ALPB(53.71,"C",IEN,ALPBX)) Q:'ALPBX  D
+ .S ALPBY=0
+ .F  S ALPBY=$O(^ALPB(53.71,"C",IEN,ALPBX,ALPBY)) Q:'ALPBY  D
+ ..S DA=ALPBY
+ ..S DA(1)=ALPBX
+ ..S DIK="^ALPB(53.71,"_DA(1)_",1,"
+ ..D ^DIK
+ ..K DA,DIK
+ .K ALPBY
+ K ALPBX
+ Q
+ ;
+DELERR(ERRIEN) ; delete an error log entry from file 53.71...
+ ; ERRIEN = error log entry's internal record number
+ N ALPBPARM,DA,DIK,X,Y
+ S ALPBPARM=+$O(^ALPB(53.71,0))
+ I ALPBPARM'>0 Q
+ S DA=ERRIEN
+ S DA(1)=ALPBPARM
+ S DIK="^ALPB(53.71,"_DA(1)_",1,"
+ D ^DIK
+ Q
+ ;
+PTLIST(LTYPE,RESULTS) ; get list of patients in file 53.7...
+ ; LTYPE   = passed = "ALL" to list all patients or
+ ;                  = <wardname> to list patients on a selected ward
+ ; RESULTS = an array passed by reference in which data will be returned
+ N ALPBDATA,ALPBIEN,ALPBPTN,ALPBX
+ I $G(LTYPE)="" S LTYPE="ALL"
+ S ALPBX=0
+ I LTYPE="ALL" D
+ .S ALPBPTN=""
+ .F  S ALPBPTN=$O(^ALPB(53.7,"B",ALPBPTN)) Q:ALPBPTN=""  D
+ ..S ALPBIEN=0
+ ..F  S ALPBIEN=$O(^ALPB(53.7,"B",ALPBPTN,ALPBIEN)) Q:'ALPBIEN  D
+ ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0))
+ ...I ALPBDATA="" K ALPBDATA Q
+ ...S ALPBX=ALPBX+1
+ ...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7)
+ ...K ALPBDATA
+ ..K ALPBIEN
+ .K ALPBPTN
+ I LTYPE'="ALL" D
+ .S ALPBPTN=""
+ .F  S ALPBPTN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN)) Q:ALPBPTN=""  D
+ ..S ALPBIEN=0
+ ..F  S ALPBIEN=$O(^ALPB(53.7,"AW",LTYPE,ALPBPTN,ALPBIEN)) Q:'ALPBIEN  D
+ ...S ALPBDATA=$G(^ALPB(53.7,ALPBIEN,0))
+ ...I ALPBDATA="" K ALPBDATA Q
+ ...S ALPBX=ALPBX+1
+ ...S RESULTS(ALPBX)=ALPBPTN_"^"_$P(ALPBDATA,"^",2)_"^"_$P(ALPBDATA,"^",5)_"^"_$P(ALPBDATA,"^",6)_"^"_$P(ALPBDATA,"^",7)
+ ...K ALPBDATA
+ ..K ALPBIEN
+ .K ALPBPTN
+ Q
+ ;
+STAT(ST) ;This will return the value of a status code for pharmacy
+ I $G(ST)="" Q ""
+ I $L($T(@ST)) G @ST
+ Q ""
+IP Q "pending"
+CM Q "finished/verified by pharmacist(active)"
+DC Q "discontinued"
+RP Q "replaced"
+HD Q "on hold"
+ZE Q "expired"
+ZS Q "suspended(active)"
+ZU Q "un-suspended(active)"
+ZX Q "unreleased"
+ZZ Q "renewed"
+ ;
+STAT2(CODE) ; convert order status code for output...
+ ; this function is used primarily by the workstation software
+ ; CODE = an order status code
+ ; returns printable status code
+ I $G(CODE)="" Q "Unknown"
+ I CODE="IP"!(CODE="ZX") Q "Pending"
+ I CODE="CM"!(CODE="ZU")!(CODE="ZZ") Q "Active"
+ I CODE="HD"!(CODE="ZS") Q "Hold"
+ I CODE="DC"!(CODE="RP")!(CODE="ZE") Q "Expired"
+ Q "Unknown"
+ ;
+DIV(DFN,ALPBMDT) ;get the Division for a patient
+ I +$G(DFN)'>0 Q ""
+ N ALPBDIV,ALPWRD,VAIN,VAINDT
+ S:+$G(ALPBMDT)>0 VAINDT=$P(ALPBMDT,".",1)
+ K ALPBMDT
+ D INP^VADPT
+ S ALPWRD=$P($G(VAIN(4)),U,1)
+ Q:+ALPWRD'>0 ""
+ ;Check to see if ward is a DOMICILIARY 
+ I $P($G(^DIC(42,ALPWRD,0)),U,3)="D" Q "DOM"
+ S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11)
+ Q:+ALPBDIV'>0 ""
+ Q ALPBDIV
+ ;
+CNV(A,B,X) ;CONVERT A STRING
+ ;This API will take a HL7 segment and convert characters
+ ;defined in the input
+ ;Example:
+ ;Single encoding characters can be converted such as ^ to ~
+ ;or multiple encoding characters can be converted such as
+ ;  |~^@/ to ^~|/@
+ ;A is the string of HL7 encoding characters to be converted
+ ;B is the string of HL7 encoding characters to be converted to
+ ;X is te message string to be converted
+ I A=""!B=""!X="" Q ""
+ F I=1:1:$L(A) S A(I)=$E(A,I,I),A(I,1)=""
+ F I=1:1:$L(B) S B(I)=$E(B,I,I)
+ S J=0
+ F  S J=$O(A(J)) Q:+J'>0  D
+ . F I=1:1:$L(X) S:$E(X,I,I)=A(J) A(J,1)=A(J,1)_I_U
+ S J=0
+ F  S J=$O(A(J)) Q:+J'>0  D
+ . Q:'$D(A(J,1))!'$D(B(J))
+ . F I=1:1:$L(A(J,1),U) S C=$P(A(J,1),U,I) S:+C>0 $E(X,C,C)=B(J)
+ Q X
