- 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 Jan 18, 2025@03:27:37 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