VAQDBIP2 ;ALB/JRP - PDX EXTRACTION UTILITY;16-MAR-93
;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
XTRCT(INFOLINE,DFN,RXIFN,ARRAY,ENCPTR,KEY1,KEY2) ;EXTRACT INFORMATION
;INPUT : INFOLINE - Line containing information to extract
; DFN - Pointer to patient in PATIENT file
; RXIFN - Pointer to prescription in PRESCRIPTION file
; ARRAY - Extraction array (full global reference)
; ENCPTR - Pointer to VAQ - ENCRYPTION METHOD file (optional)
; (only used if encryption will be done)
; KEY1 - Primary encryption key
; (only required if ENCPTR passed)
; KEY2 - Secondary encryption key
; (only required if ENCPTR passed)
;OUTPUT : 0 - Extraction was successfull
; Information stored in extraction array
; -1^Error_Text - Extraction was not successfull
;NOTES : INFOLINE is in the format
; <TAB>;File;Field,Field,...,Field;Multiple Limit;Reverse Order Mult
; : 'Multiple Limit' is the number of multiples to extract
; (defaults to all)
; : If 'Reverse Order Mult' contains a value other than 0,
; multiples will be extracted in reverse order (last in
; first out). If it does not have a value or is 0,
; multiples will be extracted in normal fashion (first in
; first out).
;
;CHECK INPUT
Q:($G(INFOLINE)="") "-1^Did not pass info line"
Q:($G(DFN)="") "-1^Did not pass pointer to PATIENT file"
S RXIFN=$G(RXIFN)
S ENCPTR=+$G(ENCPTR)
S KEY1=$G(KEY1)
S KEY2=$G(KEY2)
I (ENCPTR) Q:((KEY1="")!(KEY2="")) "-1^Did not pass both encription keys"
;DECLARE VARIABLES
N TMP,FILE,FIELDS,MAINFILE,MAINFLD,GLOBAL,NODE,STRING
N WORDPROC,ENTRY,ERROR,MULTLIM,COUNT,MULTREV,ENCRYPT
N DIC,DR,DA,DIQ,SEQUENCE,ID,RXNUM,PATNAME,FIELD,ENCSTR
;SAFE GUARD DELETION OF UTILITY GLOBAL
K ^UTILITY("DIQ1",$J)
;GET ENCRYPTION METHOD
S TMP="STRING"
S:(ENCPTR) TMP=$$ENCMTHD^VAQUTL2(ENCPTR,0)
Q:((ENCPTR)&(TMP="")) "-1^Could not determine encryption method"
S ENCRYPT="S ENCSTR="_TMP
;GET PATIENT'S NAME
S TMP=$$PATINFO^VAQUTL1(DFN)
S STRING=$P(TMP,"^",1)
Q:(STRING="-1") "-1^Could not determine patient's name"
;ENCRYPT
S ENCSTR=STRING
I $$NCRPFLD^VAQUTL2(2,.01) X ENCRYPT
S PATNAME=ENCSTR
;GET RX #
I (RXIFN'="") D
.S DIC="^PSRX("
.S DR=.01
.S DA=RXIFN
.S DIQ(0)="E"
.D EN^DIQ1
.S STRING=$G(^UTILITY("DIQ1",$J,52,RXIFN,.01,"E"))
.;ENCRYPT
.S ENCSTR=STRING
.I $$NCRPFLD^VAQUTL2(52,.01) X ENCRYPT
.S RXNUM=ENCSTR
.;TESTING OF RESULT DONE IF NEEDED LATER ON
.K ^UTILITY("DIQ1",$J)
S ERROR=0
S FILE=$P(INFOLINE,";",3)
S FIELDS=$P(INFOLINE,";",4)
S MULTLIM=$P(INFOLINE,";",5)
S MULTREV=$P(INFOLINE,";",6)
;CHECK FOR MULTIPLE
S MAINFILE=$G(^DD(FILE,0,"UP"))
;CHECK FOR WORD-PROCESSING FIELD
S WORDPROC=$F($P($G(^DD(FILE,.01,0)),"^",2),"W")
;NON-MULTIPLE
I (MAINFILE="") D Q ERROR
.I ((FILE=52)&(RXIFN="")) S ERROR="-1^Pointer to PRESCRIPTION file not passed" Q
.S DIC=FILE
.S DR=$TR(FIELDS,",",";")
.S DA=$S(FILE=52:RXIFN,1:DFN)
.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)
..;DETERMINE IDENTIFIER
..S ID=PATNAME
..S:((FILE=52)&(FIELD'=.01)) ID=RXNUM
..S STRING=$G(^UTILITY("DIQ1",$J,FILE,DA,FIELD,"E"))
..;ENCRYPT
..S ENCSTR=STRING
..I $$NCRPFLD^VAQUTL2(FILE,FIELD) X ENCRYPT
..S @ARRAY@("VALUE",FILE,FIELD,SEQUENCE)=ENCSTR
..S @ARRAY@("ID",FILE,FIELD,SEQUENCE)=ID
.K ^UTILITY("DIQ1",$J)
;MULTIPLE
I ((MAINFILE'="")&('WORDPROC)) D MLTPLE^VAQDBIP5 Q ERROR
;WORD-PROCESSING FIELD
I ((MAINFILE'="")&(WORDPROC)) D WORD^VAQDBIP5 Q ERROR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQDBIP2 3804 printed Sep 23, 2025@20:00:49 Page 2
VAQDBIP2 ;ALB/JRP - PDX EXTRACTION UTILITY;16-MAR-93
+1 ;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
XTRCT(INFOLINE,DFN,RXIFN,ARRAY,ENCPTR,KEY1,KEY2) ;EXTRACT INFORMATION
+1 ;INPUT : INFOLINE - Line containing information to extract
+2 ; DFN - Pointer to patient in PATIENT file
+3 ; RXIFN - Pointer to prescription in PRESCRIPTION file
+4 ; ARRAY - Extraction array (full global reference)
+5 ; ENCPTR - Pointer to VAQ - ENCRYPTION METHOD file (optional)
+6 ; (only used if encryption will be done)
+7 ; KEY1 - Primary encryption key
+8 ; (only required if ENCPTR passed)
+9 ; KEY2 - Secondary encryption key
+10 ; (only required if ENCPTR passed)
+11 ;OUTPUT : 0 - Extraction was successfull
+12 ; Information stored in extraction array
+13 ; -1^Error_Text - Extraction was not successfull
+14 ;NOTES : INFOLINE is in the format
+15 ; <TAB>;File;Field,Field,...,Field;Multiple Limit;Reverse Order Mult
+16 ; : 'Multiple Limit' is the number of multiples to extract
+17 ; (defaults to all)
+18 ; : If 'Reverse Order Mult' contains a value other than 0,
+19 ; multiples will be extracted in reverse order (last in
+20 ; first out). If it does not have a value or is 0,
+21 ; multiples will be extracted in normal fashion (first in
+22 ; first out).
+23 ;
+24 ;CHECK INPUT
+25 if ($GET(INFOLINE)="")
QUIT "-1^Did not pass info line"
+26 if ($GET(DFN)="")
QUIT "-1^Did not pass pointer to PATIENT file"
+27 SET RXIFN=$GET(RXIFN)
+28 SET ENCPTR=+$GET(ENCPTR)
+29 SET KEY1=$GET(KEY1)
+30 SET KEY2=$GET(KEY2)
+31 IF (ENCPTR)
if ((KEY1="")!(KEY2=""))
QUIT "-1^Did not pass both encription keys"
+32 ;DECLARE VARIABLES
+33 NEW TMP,FILE,FIELDS,MAINFILE,MAINFLD,GLOBAL,NODE,STRING
+34 NEW WORDPROC,ENTRY,ERROR,MULTLIM,COUNT,MULTREV,ENCRYPT
+35 NEW DIC,DR,DA,DIQ,SEQUENCE,ID,RXNUM,PATNAME,FIELD,ENCSTR
+36 ;SAFE GUARD DELETION OF UTILITY GLOBAL
+37 KILL ^UTILITY("DIQ1",$JOB)
+38 ;GET ENCRYPTION METHOD
+39 SET TMP="STRING"
+40 if (ENCPTR)
SET TMP=$$ENCMTHD^VAQUTL2(ENCPTR,0)
+41 if ((ENCPTR)&(TMP=""))
QUIT "-1^Could not determine encryption method"
+42 SET ENCRYPT="S ENCSTR="_TMP
+43 ;GET PATIENT'S NAME
+44 SET TMP=$$PATINFO^VAQUTL1(DFN)
+45 SET STRING=$PIECE(TMP,"^",1)
+46 if (STRING="-1")
QUIT "-1^Could not determine patient's name"
+47 ;ENCRYPT
+48 SET ENCSTR=STRING
+49 IF $$NCRPFLD^VAQUTL2(2,.01)
XECUTE ENCRYPT
+50 SET PATNAME=ENCSTR
+51 ;GET RX #
+52 IF (RXIFN'="")
Begin DoDot:1
+53 SET DIC="^PSRX("
+54 SET DR=.01
+55 SET DA=RXIFN
+56 SET DIQ(0)="E"
+57 DO EN^DIQ1
+58 SET STRING=$GET(^UTILITY("DIQ1",$JOB,52,RXIFN,.01,"E"))
+59 ;ENCRYPT
+60 SET ENCSTR=STRING
+61 IF $$NCRPFLD^VAQUTL2(52,.01)
XECUTE ENCRYPT
+62 SET RXNUM=ENCSTR
+63 ;TESTING OF RESULT DONE IF NEEDED LATER ON
+64 KILL ^UTILITY("DIQ1",$JOB)
End DoDot:1
+65 SET ERROR=0
+66 SET FILE=$PIECE(INFOLINE,";",3)
+67 SET FIELDS=$PIECE(INFOLINE,";",4)
+68 SET MULTLIM=$PIECE(INFOLINE,";",5)
+69 SET MULTREV=$PIECE(INFOLINE,";",6)
+70 ;CHECK FOR MULTIPLE
+71 SET MAINFILE=$GET(^DD(FILE,0,"UP"))
+72 ;CHECK FOR WORD-PROCESSING FIELD
+73 SET WORDPROC=$FIND($PIECE($GET(^DD(FILE,.01,0)),"^",2),"W")
+74 ;NON-MULTIPLE
+75 IF (MAINFILE="")
Begin DoDot:1
+76 IF ((FILE=52)&(RXIFN=""))
SET ERROR="-1^Pointer to PRESCRIPTION file not passed"
QUIT
+77 SET DIC=FILE
+78 SET DR=$TRANSLATE(FIELDS,",",";")
+79 SET DA=$SELECT(FILE=52:RXIFN,1:DFN)
+80 SET DIQ(0)="E"
+81 KILL ^UTILITY("DIQ1",$JOB)
+82 DO EN^DIQ1
+83 ;STORE IN EXTRACTION ARRAY
+84 FOR TMP=1:1:$LENGTH(FIELDS,",")
Begin DoDot:2
+85 SET FIELD=$PIECE(FIELDS,",",TMP)
+86 SET SEQUENCE=$$GETSEQ^VAQDBIP(ARRAY,FILE,FIELD)
+87 ;DETERMINE IDENTIFIER
+88 SET ID=PATNAME
+89 if ((FILE=52)&(FIELD'=.01))
SET ID=RXNUM
+90 SET STRING=$GET(^UTILITY("DIQ1",$JOB,FILE,DA,FIELD,"E"))
+91 ;ENCRYPT
+92 SET ENCSTR=STRING
+93 IF $$NCRPFLD^VAQUTL2(FILE,FIELD)
XECUTE ENCRYPT
+94 SET @ARRAY@("VALUE",FILE,FIELD,SEQUENCE)=ENCSTR
+95 SET @ARRAY@("ID",FILE,FIELD,SEQUENCE)=ID
End DoDot:2
+96 KILL ^UTILITY("DIQ1",$JOB)
End DoDot:1
QUIT ERROR
+97 ;MULTIPLE
+98 IF ((MAINFILE'="")&('WORDPROC))
DO MLTPLE^VAQDBIP5
QUIT ERROR
+99 ;WORD-PROCESSING FIELD
+100 IF ((MAINFILE'="")&(WORDPROC))
DO WORD^VAQDBIP5
QUIT ERROR
+101 QUIT
