VAQUTL1 ;ALB/JRP - UTILITY ROUTINES;30-APR-93
;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
REPEAT(CHAR,TIMES) ;REPEAT A STRING
;INPUT : CHAR - Character to repeat
; TIMES - Number of times to repeat CHAR
;OUTPUT : s - String of CHAR that is TIMES long
; "" - Error (bad input)
;
;CHECK INPUT
Q:($G(CHAR)="") ""
Q:((+$G(TIMES))=0) ""
;RETURN STRING
Q $TR($J("",TIMES)," ",CHAR)
INSERT(INSTR,OUTSTR,COLUMN,LENGTH) ;INSERT A STRING INTO ANOTHER
;INPUT : INSTR - String to insert
; OUTSTR - String to insert into
; COLUMN - Where to begin insertion (defaults to end of OUTSTR)
; LENGTH - Number of characters to clear from OUTSTR
; (defaults to length of INSTR)
;OUTPUT : s - INSTR will be placed into OUTSTR starting at COLUMN
; using LENGTH characters
; "" - Error (bad input)
;
;NOTE : This module is based on $$SETSTR^VALM1
;
;CHECK INPUT
Q:('$D(INSTR)) ""
Q:('$D(OUTSTR)) ""
S:('$D(COLUMN)) COLUMN=$L(OUTSTR)+1
S:('$D(LENGTH)) LENGTH=$L(INSTR)
;DECLARE VARIABLES
N FRONT,END
S FRONT=$E((OUTSTR_$J("",COLUMN-1)),1,(COLUMN-1))
S END=$E(OUTSTR,(COLUMN+LENGTH),$L(OUTSTR))
;INSERT STRING
Q FRONT_$E((INSTR_$J("",LENGTH)),1,LENGTH)_END
KILLARR(ARRAY,NODE,START,END) ;KILL NODES OF AN ARRAY
;INPUT : ARRAY - Array to kill nodes in (full global reference)
; NODE - Subscript to kill (optional)
; START - Subscript to start killing at (default to first)
; END - Subscript to stop killing at (default to all)
;OUTPUT : 0 - Success
; -1 - Error
;
;NOTES:
; If NODE is passed KILLing takes place at
; @ARRAY@(NODE,x)
; If NODE is not passed KILLing takes place at
; @ARRAY@(x)
;
; If START is passed KILLing starts at
; @ARRAY@([NODE,]START)
; If START is not passed KILLing starts on first node after
; @ARRAY@([NODE,],"")
;
; If END is passed KILLing ends on first node after
; @ARRAR@([NODE,],END)
; If END is not passed KILLing ends on first node after
; @ARRAY@([NODE])
;CHECK INPUT
Q:($G(ARRAY)="") -1
S NODE=$G(NODE)
S START=$G(START)
S END=$G(END)
;DECLARE VARIABLES
N LOOP,SUBSCRPT
;KILL STARTING SUBSCRIPT
I (START'="")&(NODE'="") K @ARRAY@(NODE,START)
I (START'="")&(NODE="") K @ARRAY@(START)
;KILL NODES
F LOOP=0:0 D Q:(SUBSCRPT="")
.I (NODE="") S SUBSCRPT=$O(@ARRAY@(START))
.I (NODE'="") S SUBSCRPT=$O(@ARRAY@(NODE,START))
.Q:(SUBSCRPT="")
.I (NODE="") K @ARRAY@(SUBSCRPT)
.I (NODE'="") K @ARRAY@(NODE,SUBSCRPT)
.S:(SUBSCRPT=END) SUBSCRPT=""
Q 0
PATINFO(DFN) ;RETURNS PATIENT NAME, SSN, DOB, PATIENT ID
;INPUT : DFN - Pointer to patient in PATIENT file
;OUTPUT : Name^SSN^DOB^PID - Success
; -1^Error_Text - Error
;NOTES : SSN returned without dashes
; DOB returned in external format
;
;CHECK INPUT
S DFN=+$G(DFN)
Q:('DFN) "-1^Pointer to PATIENT file not passed"
;DECLARE VARIABLES
N VAPTYP,VAHOW,VAROOT,VAERR,VA,TMP,Y,%DT
S VAHOW=2
K ^UTILITY("VADM",$J)
D DEM^VADPT
Q:(VAERR) "-1^Unable to gather patient information"
S TMP=^UTILITY("VADM",$J,1)
S $P(TMP,"^",2)=$P(^UTILITY("VADM",$J,2),"^",1)
S Y=+^UTILITY("VADM",$J,3) D DD^%DT S $P(TMP,"^",3)=Y
S $P(TMP,"^",4)=VA("PID")
K ^UTILITY("VADM",$J)
Q TMP
;
PDXVER() ;RETURN VERSION OF PDX IN USE
;INPUT : None
;OUTPUT : N - Version of PDX in use at facility
; -1^Error_Text - Error
;
;DECLARE VARIABLES
N X,Y
S X=+$G(^DD(394.61,0,"VR"))
S Y=$D(^DD(394))
;NOT INSTALLED
Q:(('X)&('Y)) "-1^PDX has not been installed"
;VERSION 1.0
Q:(('X)&(Y)) "1.0"
;VERSION 1.5 AND UP
Q X
;
APDX ;CONTINUATION OF APDX X-REF ON *PDX TRANSACTION FILE (# 394)
; THIS IS LEFT OVER FROM VERSION 1.0 - INCLUDED TO PASS %INDEX
S:($P(^VAT(394,DA,0),U,12)=VAQ15)!($P(^(0),U,12)=VAQ16) ^VAT(394,"APDX",$P(^(0),U,4),X,(9999999.999999-$P(^(0),U,1)),DA)=""
K:VAQTMP=1 VAQ15,VAQ16 K VAQTMP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQUTL1 4015 printed Sep 23, 2025@20:02:35 Page 2
VAQUTL1 ;ALB/JRP - UTILITY ROUTINES;30-APR-93
+1 ;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
REPEAT(CHAR,TIMES) ;REPEAT A STRING
+1 ;INPUT : CHAR - Character to repeat
+2 ; TIMES - Number of times to repeat CHAR
+3 ;OUTPUT : s - String of CHAR that is TIMES long
+4 ; "" - Error (bad input)
+5 ;
+6 ;CHECK INPUT
+7 if ($GET(CHAR)="")
QUIT ""
+8 if ((+$GET(TIMES))=0)
QUIT ""
+9 ;RETURN STRING
+10 QUIT $TRANSLATE($JUSTIFY("",TIMES)," ",CHAR)
INSERT(INSTR,OUTSTR,COLUMN,LENGTH) ;INSERT A STRING INTO ANOTHER
+1 ;INPUT : INSTR - String to insert
+2 ; OUTSTR - String to insert into
+3 ; COLUMN - Where to begin insertion (defaults to end of OUTSTR)
+4 ; LENGTH - Number of characters to clear from OUTSTR
+5 ; (defaults to length of INSTR)
+6 ;OUTPUT : s - INSTR will be placed into OUTSTR starting at COLUMN
+7 ; using LENGTH characters
+8 ; "" - Error (bad input)
+9 ;
+10 ;NOTE : This module is based on $$SETSTR^VALM1
+11 ;
+12 ;CHECK INPUT
+13 if ('$DATA(INSTR))
QUIT ""
+14 if ('$DATA(OUTSTR))
QUIT ""
+15 if ('$DATA(COLUMN))
SET COLUMN=$LENGTH(OUTSTR)+1
+16 if ('$DATA(LENGTH))
SET LENGTH=$LENGTH(INSTR)
+17 ;DECLARE VARIABLES
+18 NEW FRONT,END
+19 SET FRONT=$EXTRACT((OUTSTR_$JUSTIFY("",COLUMN-1)),1,(COLUMN-1))
+20 SET END=$EXTRACT(OUTSTR,(COLUMN+LENGTH),$LENGTH(OUTSTR))
+21 ;INSERT STRING
+22 QUIT FRONT_$EXTRACT((INSTR_$JUSTIFY("",LENGTH)),1,LENGTH)_END
KILLARR(ARRAY,NODE,START,END) ;KILL NODES OF AN ARRAY
+1 ;INPUT : ARRAY - Array to kill nodes in (full global reference)
+2 ; NODE - Subscript to kill (optional)
+3 ; START - Subscript to start killing at (default to first)
+4 ; END - Subscript to stop killing at (default to all)
+5 ;OUTPUT : 0 - Success
+6 ; -1 - Error
+7 ;
+8 ;NOTES:
+9 ; If NODE is passed KILLing takes place at
+10 ; @ARRAY@(NODE,x)
+11 ; If NODE is not passed KILLing takes place at
+12 ; @ARRAY@(x)
+13 ;
+14 ; If START is passed KILLing starts at
+15 ; @ARRAY@([NODE,]START)
+16 ; If START is not passed KILLing starts on first node after
+17 ; @ARRAY@([NODE,],"")
+18 ;
+19 ; If END is passed KILLing ends on first node after
+20 ; @ARRAR@([NODE,],END)
+21 ; If END is not passed KILLing ends on first node after
+22 ; @ARRAY@([NODE])
+23 ;CHECK INPUT
+24 if ($GET(ARRAY)="")
QUIT -1
+25 SET NODE=$GET(NODE)
+26 SET START=$GET(START)
+27 SET END=$GET(END)
+28 ;DECLARE VARIABLES
+29 NEW LOOP,SUBSCRPT
+30 ;KILL STARTING SUBSCRIPT
+31 IF (START'="")&(NODE'="")
KILL @ARRAY@(NODE,START)
+32 IF (START'="")&(NODE="")
KILL @ARRAY@(START)
+33 ;KILL NODES
+34 FOR LOOP=0:0
Begin DoDot:1
+35 IF (NODE="")
SET SUBSCRPT=$ORDER(@ARRAY@(START))
+36 IF (NODE'="")
SET SUBSCRPT=$ORDER(@ARRAY@(NODE,START))
+37 if (SUBSCRPT="")
QUIT
+38 IF (NODE="")
KILL @ARRAY@(SUBSCRPT)
+39 IF (NODE'="")
KILL @ARRAY@(NODE,SUBSCRPT)
+40 if (SUBSCRPT=END)
SET SUBSCRPT=""
End DoDot:1
if (SUBSCRPT="")
QUIT
+41 QUIT 0
PATINFO(DFN) ;RETURNS PATIENT NAME, SSN, DOB, PATIENT ID
+1 ;INPUT : DFN - Pointer to patient in PATIENT file
+2 ;OUTPUT : Name^SSN^DOB^PID - Success
+3 ; -1^Error_Text - Error
+4 ;NOTES : SSN returned without dashes
+5 ; DOB returned in external format
+6 ;
+7 ;CHECK INPUT
+8 SET DFN=+$GET(DFN)
+9 if ('DFN)
QUIT "-1^Pointer to PATIENT file not passed"
+10 ;DECLARE VARIABLES
+11 NEW VAPTYP,VAHOW,VAROOT,VAERR,VA,TMP,Y,%DT
+12 SET VAHOW=2
+13 KILL ^UTILITY("VADM",$JOB)
+14 DO DEM^VADPT
+15 if (VAERR)
QUIT "-1^Unable to gather patient information"
+16 SET TMP=^UTILITY("VADM",$JOB,1)
+17 SET $PIECE(TMP,"^",2)=$PIECE(^UTILITY("VADM",$JOB,2),"^",1)
+18 SET Y=+^UTILITY("VADM",$JOB,3)
DO DD^%DT
SET $PIECE(TMP,"^",3)=Y
+19 SET $PIECE(TMP,"^",4)=VA("PID")
+20 KILL ^UTILITY("VADM",$JOB)
+21 QUIT TMP
+22 ;
PDXVER() ;RETURN VERSION OF PDX IN USE
+1 ;INPUT : None
+2 ;OUTPUT : N - Version of PDX in use at facility
+3 ; -1^Error_Text - Error
+4 ;
+5 ;DECLARE VARIABLES
+6 NEW X,Y
+7 SET X=+$GET(^DD(394.61,0,"VR"))
+8 SET Y=$DATA(^DD(394))
+9 ;NOT INSTALLED
+10 if (('X)&('Y))
QUIT "-1^PDX has not been installed"
+11 ;VERSION 1.0
+12 if (('X)&(Y))
QUIT "1.0"
+13 ;VERSION 1.5 AND UP
+14 QUIT X
+15 ;
APDX ;CONTINUATION OF APDX X-REF ON *PDX TRANSACTION FILE (# 394)
+1 ; THIS IS LEFT OVER FROM VERSION 1.0 - INCLUDED TO PASS %INDEX
+2 if ($PIECE(^VAT(394,DA,0),U,12)=VAQ15)!($PIECE(^(0),U,12)=VAQ16)
SET ^VAT(394,"APDX",$PIECE(^(0),U,4),X,(9999999.999999-$PIECE(^(0),U,1)),DA)=""
+3 if VAQTMP=1
KILL VAQ15,VAQ16
KILL VAQTMP
+4 QUIT
