VAQUTL99 ;ALB/JFP,JRP - Various Function Calls;03FEB93
;;1.5;PATIENT DATA EXCHANGE;**2,10,29**;NOV 17, 1993
;
FUNCT ; *************** Function Calls ***************
;
DASHSSN(SSN) ; -- Returns dash version of SSN
; INPUT : SSN - SSN without dashes
; OUTPUT : N - SSN with dashes
Q:($G(SSN)="") ""
Q:($E(SSN,10)'="P") $E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)
Q $E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)
;
AGE(DOB) ; -- Returns age based on date of birth
; INPUT : X1 = DOB - INTERNAL FORMAT
; X2 - TODAYS DATE
; OUTPUT : AGE IN YEARS
N X,X1,X2
Q:($G(DOB)="") ""
S X1=DT,X2=DOB
D ^%DTC
Q X\365.25
;
DOBFMT(IDTE,STYLE) ; -- Returns formatted date
; INPUT : IDTE- INTERNAL FILEMAN DATE
; STYLE - FLAG INDICATING OUTPUT STYLE
; IF 0, OUTPUT IN MM-DD-YYYY FORMAT (DEFAULT)
; IF 1, OUTPUT IN MMM DD, YYYY FORMAT
; (MMM -> FIRST 3 CHARACTERS OF MONTH NAME)
; OUTPUT : EXTERNAL DATE IN SPECIFIED FORMAT
S STYLE=+$G(STYLE)
Q:($G(IDTE)="") ""
;MM-DD-YYYY
Q:('STYLE) $E(IDTE,4,5)_"-"_$E(IDTE,6,7)_"-"_($E(IDTE,1,3)+1700)
;MMM DD, YYYY
N Y,%DT
S Y=$P(IDTE,".",1)
D DD^%DT
Q Y
;
DATE(EDTE) ; -- Converts external date to internal date format
; INPUT : EXTERNAL DATE (TIME IS OPTIONAL)
; OUTOUT: INTERNAL DATE, STORAGE FORMAT YYYMMMDD
; (TIME WILL BE RETURNED IF INCLUDED WITH INPUT)
;
Q:'$D(EDTE) -1
N X,%DT,Y
S X=EDTE
S %DT="TS"
D ^%DT
Q Y
;
NOW(FMFORM,NOTIME) ;RETURNS CURRENT DATE & TIME
;INPUT : FMFORM - Flag indicating if FileMan format should be used
; If 0, return in the format MM-DD-YYYY@HH:MM:SS
; (default)
; If 1, return in FileMan format
; NOTIME - Flag indicating if time should not be included
; If 0, time will be included in output (default)
; If 1, time will not be included in output
;OUTPUT : Current date & time in specified format
;
;CHECK INPUT
S FMFORM=+$G(FMFORM)
S NOTIME=+$G(NOTIME)
;DECLARE VARIABLES
N X,%,%H,%I,OUT
S OUT="-1^Error occurred while determining current date and time"
;GET CURRENT DATE/TIME
D NOW^%DTC
;FILEMAN FORMAT
I (FMFORM) S OUT=$S(NOTIME:X,1:%)
;EXTERNAL FORMAT
I ('FMFORM) D
.S %=%_"000000"
.S X=$E(%,4,5)_"-"_$E(%,6,7)_"-"_(1700+$E(%,1,3))_"@"_$E(%,9,10)_":"_$E(%,11,12)_":"_$E(%,13,14)
.S OUT=$S(NOTIME:$P(X,"@",1),1:X)
Q OUT
;
RES(DOMAIN,SSN) ; -- Determines whether a request is manually or
; automatically processed and returns the reason
;
; INPUT : DOMAIN = E-mail address of facility
; SSN = requested name or SSN in internal
; format
;
; OUTPUT : 1^DFN = automatic process
; -N^Reason = manual process
; where
; -1 = bad input or no input, error
; -2 = patient not found
; -3 = ambiguous patient (not currently used)
; -4 = sensitive patient
; -5 = domain not in work group
;
N SENPT,DFN,DOMDA
Q:($G(SSN)="") "-1^Did not pass patient's name or SSN"
Q:($G(DOMAIN)="") "-1^Did not pass remote domain"
;
S DFN=$$GETDFN^VAQUTL97(SSN,1)
Q:DFN=-1 "-2^Patient not found"
;
S SENPT=$$GETSEN^VAQUTL97(+DFN)
Q:SENPT=1 "-4^Sensitive patient"
;
S DOMDA=+$$FIND1^DIC(4.2,"","BMX",DOMAIN,"B^C","","ERROR")
Q:'$D(^VAT(394.82,"C",DOMDA)) "-5^Domain not in work group"
;
Q ("1^"_(+DFN)) ; -- Automatic process
;
DA(FLE,DNPT) ; -- Returns entry number in sub file (DA)
;
; INPUT : FLE = Sub file number
; DNPT = Pointer to patient in main file
;
; OUTPUT : DA = Entry number to sub file
; -1 = bad input or no input, error
;
N MFLE,GLOBAL,NODE,SUBNO,ENTRY,ND
Q:'$D(FLE) -1
Q:'$D(DNPT) -1
;
S MFLE=$G(^DD(FLE,0,"UP"))
S MFLD="",MFLD=$O(^DD(MFLE,"SB",FLE,MFLD))
S GLOBAL=$G(^DIC(MFLE,0,"GL"))
S NODE=$G(^DD(MFLE,MFLD,0))
S SUBNO=$P($P(NODE,U,4),";",1)
S ND=GLOBAL_DNPT_","_SUBNO_",0)"
S NODE=$G(@ND)
S ENTRY=$P(NODE,U,4)
Q ENTRY ; -- entry number in subfile
;
END ; -- End of code
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQUTL99 4638 printed Apr 09, 2024@21:29:13 Page 2
VAQUTL99 ;ALB/JFP,JRP - Various Function Calls;03FEB93
+1 ;;1.5;PATIENT DATA EXCHANGE;**2,10,29**;NOV 17, 1993
+2 ;
FUNCT ; *************** Function Calls ***************
+1 ;
DASHSSN(SSN) ; -- Returns dash version of SSN
+1 ; INPUT : SSN - SSN without dashes
+2 ; OUTPUT : N - SSN with dashes
+3 if ($GET(SSN)="")
QUIT ""
+4 if ($EXTRACT(SSN,10)'="P")
QUIT $EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9)
+5 QUIT $EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,10)
+6 ;
AGE(DOB) ; -- Returns age based on date of birth
+1 ; INPUT : X1 = DOB - INTERNAL FORMAT
+2 ; X2 - TODAYS DATE
+3 ; OUTPUT : AGE IN YEARS
+4 NEW X,X1,X2
+5 if ($GET(DOB)="")
QUIT ""
+6 SET X1=DT
SET X2=DOB
+7 DO ^%DTC
+8 QUIT X\365.25
+9 ;
DOBFMT(IDTE,STYLE) ; -- Returns formatted date
+1 ; INPUT : IDTE- INTERNAL FILEMAN DATE
+2 ; STYLE - FLAG INDICATING OUTPUT STYLE
+3 ; IF 0, OUTPUT IN MM-DD-YYYY FORMAT (DEFAULT)
+4 ; IF 1, OUTPUT IN MMM DD, YYYY FORMAT
+5 ; (MMM -> FIRST 3 CHARACTERS OF MONTH NAME)
+6 ; OUTPUT : EXTERNAL DATE IN SPECIFIED FORMAT
+7 SET STYLE=+$GET(STYLE)
+8 if ($GET(IDTE)="")
QUIT ""
+9 ;MM-DD-YYYY
+10 if ('STYLE)
QUIT $EXTRACT(IDTE,4,5)_"-"_$EXTRACT(IDTE,6,7)_"-"_($EXTRACT(IDTE,1,3)+1700)
+11 ;MMM DD, YYYY
+12 NEW Y,%DT
+13 SET Y=$PIECE(IDTE,".",1)
+14 DO DD^%DT
+15 QUIT Y
+16 ;
DATE(EDTE) ; -- Converts external date to internal date format
+1 ; INPUT : EXTERNAL DATE (TIME IS OPTIONAL)
+2 ; OUTOUT: INTERNAL DATE, STORAGE FORMAT YYYMMMDD
+3 ; (TIME WILL BE RETURNED IF INCLUDED WITH INPUT)
+4 ;
+5 if '$DATA(EDTE)
QUIT -1
+6 NEW X,%DT,Y
+7 SET X=EDTE
+8 SET %DT="TS"
+9 DO ^%DT
+10 QUIT Y
+11 ;
NOW(FMFORM,NOTIME) ;RETURNS CURRENT DATE & TIME
+1 ;INPUT : FMFORM - Flag indicating if FileMan format should be used
+2 ; If 0, return in the format MM-DD-YYYY@HH:MM:SS
+3 ; (default)
+4 ; If 1, return in FileMan format
+5 ; NOTIME - Flag indicating if time should not be included
+6 ; If 0, time will be included in output (default)
+7 ; If 1, time will not be included in output
+8 ;OUTPUT : Current date & time in specified format
+9 ;
+10 ;CHECK INPUT
+11 SET FMFORM=+$GET(FMFORM)
+12 SET NOTIME=+$GET(NOTIME)
+13 ;DECLARE VARIABLES
+14 NEW X,%,%H,%I,OUT
+15 SET OUT="-1^Error occurred while determining current date and time"
+16 ;GET CURRENT DATE/TIME
+17 DO NOW^%DTC
+18 ;FILEMAN FORMAT
+19 IF (FMFORM)
SET OUT=$SELECT(NOTIME:X,1:%)
+20 ;EXTERNAL FORMAT
+21 IF ('FMFORM)
Begin DoDot:1
+22 SET %=%_"000000"
+23 SET X=$EXTRACT(%,4,5)_"-"_$EXTRACT(%,6,7)_"-"_(1700+$EXTRACT(%,1,3))_"@"_$EXTRACT(%,9,10)_":"_$EXTRACT(%,11,12)_":"_$EXTRACT(%,13,14)
+24 SET OUT=$SELECT(NOTIME:$PIECE(X,"@",1),1:X)
End DoDot:1
+25 QUIT OUT
+26 ;
RES(DOMAIN,SSN) ; -- Determines whether a request is manually or
+1 ; automatically processed and returns the reason
+2 ;
+3 ; INPUT : DOMAIN = E-mail address of facility
+4 ; SSN = requested name or SSN in internal
+5 ; format
+6 ;
+7 ; OUTPUT : 1^DFN = automatic process
+8 ; -N^Reason = manual process
+9 ; where
+10 ; -1 = bad input or no input, error
+11 ; -2 = patient not found
+12 ; -3 = ambiguous patient (not currently used)
+13 ; -4 = sensitive patient
+14 ; -5 = domain not in work group
+15 ;
+16 NEW SENPT,DFN,DOMDA
+17 if ($GET(SSN)="")
QUIT "-1^Did not pass patient's name or SSN"
+18 if ($GET(DOMAIN)="")
QUIT "-1^Did not pass remote domain"
+19 ;
+20 SET DFN=$$GETDFN^VAQUTL97(SSN,1)
+21 if DFN=-1
QUIT "-2^Patient not found"
+22 ;
+23 SET SENPT=$$GETSEN^VAQUTL97(+DFN)
+24 if SENPT=1
QUIT "-4^Sensitive patient"
+25 ;
+26 SET DOMDA=+$$FIND1^DIC(4.2,"","BMX",DOMAIN,"B^C","","ERROR")
+27 if '$DATA(^VAT(394.82,"C",DOMDA))
QUIT "-5^Domain not in work group"
+28 ;
+29 ; -- Automatic process
QUIT ("1^"_(+DFN))
+30 ;
DA(FLE,DNPT) ; -- Returns entry number in sub file (DA)
+1 ;
+2 ; INPUT : FLE = Sub file number
+3 ; DNPT = Pointer to patient in main file
+4 ;
+5 ; OUTPUT : DA = Entry number to sub file
+6 ; -1 = bad input or no input, error
+7 ;
+8 NEW MFLE,GLOBAL,NODE,SUBNO,ENTRY,ND
+9 if '$DATA(FLE)
QUIT -1
+10 if '$DATA(DNPT)
QUIT -1
+11 ;
+12 SET MFLE=$GET(^DD(FLE,0,"UP"))
+13 SET MFLD=""
SET MFLD=$ORDER(^DD(MFLE,"SB",FLE,MFLD))
+14 SET GLOBAL=$GET(^DIC(MFLE,0,"GL"))
+15 SET NODE=$GET(^DD(MFLE,MFLD,0))
+16 SET SUBNO=$PIECE($PIECE(NODE,U,4),";",1)
+17 SET ND=GLOBAL_DNPT_","_SUBNO_",0)"
+18 SET NODE=$GET(@ND)
+19 SET ENTRY=$PIECE(NODE,U,4)
+20 ; -- entry number in subfile
QUIT ENTRY
+21 ;
END ; -- End of code
+1 QUIT
