VAQDBIP5 ;ALB/JRP - CONTINUATIONS FROM VAQDBIP2;23-MAR-93
;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
MLTPLE ;MULTIPLE EXTRACTION
;ALL VARIABLES ARE TAKEN CARE OF IN VAQDBIP2
;DETERMINE WHERE MULTIPLE RESIDES IN THE MAIN FILE
S GLOBAL=$G(^DIC(MAINFILE,0,"GL"))
I (GLOBAL="") S ERROR="-1^Couldn't get global root of multiple" Q
S MAINFLD=$O(^DD(MAINFILE,"SB",FILE,""))
I (MAINFLD="") S ERROR="-1^Couldn't get field number of multiple" Q
S NODE=$P($P($G(^DD(MAINFILE,MAINFLD,0)),"^",4),";",1)
I (NODE="") S ERROR="-1^Couldn't get node multiple is stored on" Q
;PUT QUOTES AROUND NON-NUMERIC NODE
I (NODE'?1.N) S NODE=$C(34)_NODE_$C(34)
S NODE=GLOBAL_$S(MAINFILE=52:RXIFN,1:DFN)_","_NODE_")"
;STORE IFNs IN TEMP ARRAY (ALLOWS FOR REVERSE ORDER EXTRACTION)
K ^TMP("VAQ",$J,$J)
S ENTRY=0
F S ENTRY=$O(@NODE@(ENTRY)) Q:('ENTRY) D
.I (MULTREV) S ^TMP("VAQ",$J,$J,(999999999999-ENTRY))=ENTRY Q
.S ^TMP("VAQ",$J,$J,ENTRY)=ENTRY
;EXTRACT EACH MULTIPLE ENTRY
S ENTRY="",COUNT=1
F S ENTRY=$O(^TMP("VAQ",$J,$J,ENTRY)) Q:(('ENTRY)!((COUNT>MULTLIM)&(MULTLIM'=""))) D
.S DIC=GLOBAL
.S DR=MAINFLD
.S DA=$S(MAINFILE=52:RXIFN,1:DFN)
.S DR(FILE)=$TR(FIELDS,",",";")
.S DA(FILE)=^TMP("VAQ",$J,$J,ENTRY)
.S DIQ(0)="E"
.K ^UTILITY("DIQ1",$J)
.D EN^DIQ1
.;STORE IN EXTRACTION ARRAY
.F TMP=1:1:$L(FIELDS,",") D
..S FIELD=$P(FIELDS,",",TMP)
..S SEQUENCE=$$GETSEQ^VAQDBIP(ARRAY,FILE,FIELD)
..;ENCRYPT POTENTIAL IDENTIFIER
..S STRING=$G(^UTILITY("DIQ1",$J,FILE,DA(FILE),.01,"E"))
..S ENCSTR=STRING
..I $$NCRPFLD^VAQUTL2(FILE,.01) X ENCRYPT
..;DETERMINE IDENTIFIER
..S ID=ENCSTR
..S:((MAINFILE'=52)&(FIELD=.01)) ID=PATNAME
..S:((MAINFILE=52)&(FIELD=.01)) ID=RXNUM
..;ENCRYPT VALUE
..S STRING=$G(^UTILITY("DIQ1",$J,FILE,DA(FILE),FIELD,"E"))
..S ENCSTR=STRING
..I $$NCRPFLD^VAQUTL2(FILE,FIELD) X ENCRYPT
..;STORE VALUE & IDENTIFIER IN EXTRACTION ARRAY
..S @ARRAY@("VALUE",FILE,FIELD,SEQUENCE)=ENCSTR
..S @ARRAY@("ID",FILE,FIELD,SEQUENCE)=ID
.K ^UTILITY("DIQ1",$J)
.S COUNT=COUNT+1
K ^TMP("VAQ",$J,$J)
Q
;
WORD ;WORD-PROCESSING FIELD EXTRACTION
;ALL VARIABLES ARE TAKEN CARE OF IN VAQDBIP2
;DETERMINE WHERE WORD-PROCESSING RESIDES IN THE MAIN FILE
S GLOBAL=$G(^DIC(MAINFILE,0,"GL"))
I (GLOBAL="") S ERROR="-1^Couldn't get global root of word-processing field" Q
S MAINFLD=$O(^DD(MAINFILE,"SB",FILE,""))
I (MAINFLD="") S ERROR="-1^Couldn't get field number of word-processing field" Q
;EXTRACT WORD-PROCESSING FIELD
S DIC=GLOBAL
S DR=MAINFLD
S DA=$S(MAINFILE=52:RXIFN,1:DFN)
S DIQ(0)="E"
K ^UTILITY("DIQ1",$J)
D EN^DIQ1
;STORE IN EXTRACTION ARRAY
S ENTRY=0
F TMP=0:0 D Q:(ENTRY="")
.S ENTRY=$O(^UTILITY("DIQ1",$J,MAINFILE,DA,MAINFLD,ENTRY))
.Q:(ENTRY="")
.S SEQUENCE=$$GETSEQ^VAQDBIP(ARRAY,FILE,.01)
.;DETERMINE IDENTIFIER
.S ID=PATNAME
.S:(MAINFILE=52) ID=RXNUM
.;ENCRYPT LINE
.S STRING=^UTILITY("DIQ1",$J,MAINFILE,DA,MAINFLD,ENTRY)
.S ENCSTR=STRING
.I $$NCRPFLD^VAQUTL2(FILE,.01) X ENCRYPT
.S @ARRAY@("VALUE",FILE,.01,SEQUENCE)=ENCSTR
.S @ARRAY@("ID",FILE,.01,SEQUENCE)=ID
K ^UTILITY("DIQ1",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQDBIP5 3138 printed Nov 22, 2024@17:35:15 Page 2
VAQDBIP5 ;ALB/JRP - CONTINUATIONS FROM VAQDBIP2;23-MAR-93
+1 ;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
MLTPLE ;MULTIPLE EXTRACTION
+1 ;ALL VARIABLES ARE TAKEN CARE OF IN VAQDBIP2
+2 ;DETERMINE WHERE MULTIPLE RESIDES IN THE MAIN FILE
+3 SET GLOBAL=$GET(^DIC(MAINFILE,0,"GL"))
+4 IF (GLOBAL="")
SET ERROR="-1^Couldn't get global root of multiple"
QUIT
+5 SET MAINFLD=$ORDER(^DD(MAINFILE,"SB",FILE,""))
+6 IF (MAINFLD="")
SET ERROR="-1^Couldn't get field number of multiple"
QUIT
+7 SET NODE=$PIECE($PIECE($GET(^DD(MAINFILE,MAINFLD,0)),"^",4),";",1)
+8 IF (NODE="")
SET ERROR="-1^Couldn't get node multiple is stored on"
QUIT
+9 ;PUT QUOTES AROUND NON-NUMERIC NODE
+10 IF (NODE'?1.N)
SET NODE=$CHAR(34)_NODE_$CHAR(34)
+11 SET NODE=GLOBAL_$SELECT(MAINFILE=52:RXIFN,1:DFN)_","_NODE_")"
+12 ;STORE IFNs IN TEMP ARRAY (ALLOWS FOR REVERSE ORDER EXTRACTION)
+13 KILL ^TMP("VAQ",$JOB,$JOB)
+14 SET ENTRY=0
+15 FOR
SET ENTRY=$ORDER(@NODE@(ENTRY))
if ('ENTRY)
QUIT
Begin DoDot:1
+16 IF (MULTREV)
SET ^TMP("VAQ",$JOB,$JOB,(999999999999-ENTRY))=ENTRY
QUIT
+17 SET ^TMP("VAQ",$JOB,$JOB,ENTRY)=ENTRY
End DoDot:1
+18 ;EXTRACT EACH MULTIPLE ENTRY
+19 SET ENTRY=""
SET COUNT=1
+20 FOR
SET ENTRY=$ORDER(^TMP("VAQ",$JOB,$JOB,ENTRY))
if (('ENTRY)!((COUNT>MULTLIM)&(MULTLIM'="")))
QUIT
Begin DoDot:1
+21 SET DIC=GLOBAL
+22 SET DR=MAINFLD
+23 SET DA=$SELECT(MAINFILE=52:RXIFN,1:DFN)
+24 SET DR(FILE)=$TRANSLATE(FIELDS,",",";")
+25 SET DA(FILE)=^TMP("VAQ",$JOB,$JOB,ENTRY)
+26 SET DIQ(0)="E"
+27 KILL ^UTILITY("DIQ1",$JOB)
+28 DO EN^DIQ1
+29 ;STORE IN EXTRACTION ARRAY
+30 FOR TMP=1:1:$LENGTH(FIELDS,",")
Begin DoDot:2
+31 SET FIELD=$PIECE(FIELDS,",",TMP)
+32 SET SEQUENCE=$$GETSEQ^VAQDBIP(ARRAY,FILE,FIELD)
+33 ;ENCRYPT POTENTIAL IDENTIFIER
+34 SET STRING=$GET(^UTILITY("DIQ1",$JOB,FILE,DA(FILE),.01,"E"))
+35 SET ENCSTR=STRING
+36 IF $$NCRPFLD^VAQUTL2(FILE,.01)
XECUTE ENCRYPT
+37 ;DETERMINE IDENTIFIER
+38 SET ID=ENCSTR
+39 if ((MAINFILE'=52)&(FIELD=.01))
SET ID=PATNAME
+40 if ((MAINFILE=52)&(FIELD=.01))
SET ID=RXNUM
+41 ;ENCRYPT VALUE
+42 SET STRING=$GET(^UTILITY("DIQ1",$JOB,FILE,DA(FILE),FIELD,"E"))
+43 SET ENCSTR=STRING
+44 IF $$NCRPFLD^VAQUTL2(FILE,FIELD)
XECUTE ENCRYPT
+45 ;STORE VALUE & IDENTIFIER IN EXTRACTION ARRAY
+46 SET @ARRAY@("VALUE",FILE,FIELD,SEQUENCE)=ENCSTR
+47 SET @ARRAY@("ID",FILE,FIELD,SEQUENCE)=ID
End DoDot:2
+48 KILL ^UTILITY("DIQ1",$JOB)
+49 SET COUNT=COUNT+1
End DoDot:1
+50 KILL ^TMP("VAQ",$JOB,$JOB)
+51 QUIT
+52 ;
WORD ;WORD-PROCESSING FIELD EXTRACTION
+1 ;ALL VARIABLES ARE TAKEN CARE OF IN VAQDBIP2
+2 ;DETERMINE WHERE WORD-PROCESSING RESIDES IN THE MAIN FILE
+3 SET GLOBAL=$GET(^DIC(MAINFILE,0,"GL"))
+4 IF (GLOBAL="")
SET ERROR="-1^Couldn't get global root of word-processing field"
QUIT
+5 SET MAINFLD=$ORDER(^DD(MAINFILE,"SB",FILE,""))
+6 IF (MAINFLD="")
SET ERROR="-1^Couldn't get field number of word-processing field"
QUIT
+7 ;EXTRACT WORD-PROCESSING FIELD
+8 SET DIC=GLOBAL
+9 SET DR=MAINFLD
+10 SET DA=$SELECT(MAINFILE=52:RXIFN,1:DFN)
+11 SET DIQ(0)="E"
+12 KILL ^UTILITY("DIQ1",$JOB)
+13 DO EN^DIQ1
+14 ;STORE IN EXTRACTION ARRAY
+15 SET ENTRY=0
+16 FOR TMP=0:0
Begin DoDot:1
+17 SET ENTRY=$ORDER(^UTILITY("DIQ1",$JOB,MAINFILE,DA,MAINFLD,ENTRY))
+18 if (ENTRY="")
QUIT
+19 SET SEQUENCE=$$GETSEQ^VAQDBIP(ARRAY,FILE,.01)
+20 ;DETERMINE IDENTIFIER
+21 SET ID=PATNAME
+22 if (MAINFILE=52)
SET ID=RXNUM
+23 ;ENCRYPT LINE
+24 SET STRING=^UTILITY("DIQ1",$JOB,MAINFILE,DA,MAINFLD,ENTRY)
+25 SET ENCSTR=STRING
+26 IF $$NCRPFLD^VAQUTL2(FILE,.01)
XECUTE ENCRYPT
+27 SET @ARRAY@("VALUE",FILE,.01,SEQUENCE)=ENCSTR
+28 SET @ARRAY@("ID",FILE,.01,SEQUENCE)=ID
End DoDot:1
if (ENTRY="")
QUIT
+29 KILL ^UTILITY("DIQ1",$JOB)
+30 QUIT
