VAQDBIP5.m

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 ---VAQDBIP5   3138     printed  Apr 23, 2025@18:39:13                                                                                                                                                                                                    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