VAQUTL97 ;ALB/JFP,JRP - PDX Patient Lookup ;24-JAN-93
;;1.5;PATIENT DATA EXCHANGE;**2,9,29,35**;NOV 17, 1993
;
GETDFN(PATIENT,TASK) ;-- Return DFN of patient
; -- This will return the same information that DIC returns in Y
N DIC,X,Y,RESULT,USRABORT
S USRABORT=-1
S:'$D(PATIENT) PATIENT=""
S:'$D(TASK) TASK=0
; -- User interface
S DIC(0)="M"
I (PATIENT="")&('TASK) S DIC(0)=DIC(0)_"A"
I (PATIENT="")&(TASK) S RESULT=USRABORT Q RESULT
S:TASK DIC(0)=DIC(0)_"XZ"
S:'TASK DIC(0)=DIC(0)_"EQZ"
S X=PATIENT
S DIC="^DPT("
; -- Prevent sensitive record bulletin if called in TASK mode
S:(TASK) DGSENFLG=""
D ^DIC
K DGSENFLG
; -- User aborted process
Q:$D(DTOUT) USRABORT
Q:$D(DUOUT) USRABORT
Q Y
;
GETSEN(DFN) ; -- Returns code for sensitive patient or not
; INPUT: DFN = Dictionary file number
; OUTPUT: 1 = Sensitive patient
; 0 = Non sensitive
; -1 = Bad input
;
Q:'$D(DFN) -1
Q:DFN="" -1
Q:DFN=0 -1
Q:'$D(^DGSL(38.1,DFN,0)) -0 ; -- not sensitive patient
Q $P($G(^DGSL(38.1,DFN,0)),U,2) ; -- 1 SENSITIVE, 0 NON-SENSITIVE
;
EXPTRN(TRANDA) ; -- Determines if any entry in the transactions file is
; marked for purge or exceed the life days.
; Also checks to make sure that requesting domain is
; not closed. If it is, it marks the transaction file
; entry for purging.
; INPUT : TRANDA DA TO TRANSACTION RECORD
; OUTOUT: -1 error in data
; 0 not expired
; 1 expired
;
N X,LDAY,PURGE
S PURGE=$P($G(^VAT(394.61,TRANDA,"PRG")),U,1)
I PURGE=1 Q 1 ; -- purge flag set
;
S X1=$$NOW^VAQUTL99(1,1) ; -- Current date
S X2=$P($G(^VAT(394.61,TRANDA,"ATHR1")),U,1)
I X2="" S X2=$P($G(^VAT(394.61,TRANDA,"RQST1")),U,1)
S X2=$P(X2,".",1)
I X2="" Q -1 ; -- error in data
;
S LDAY=$P($G(^VAT(394.81,1,"LIFE")),U,1)
I LDAY="" Q 0 ; -- no life days set
;
D ^%DTC
I X>LDAY Q 1 ; -- Expired
Q 0
CLOSDOM(TRANDA,DOMAIN) ; Function, given domain, returns whether
; the domain is closed or not. (1=closed; 0=not closed)
; If the domain is closed, then the transaction is marked for purging.
Q:'$$CLOSED(DOMAIN) 0
D SETPURGE(TRANDA)
Q 1
CLOSTRAN(TRANDA,NODE) ; Function, given transaction number, returns whether
; the domain is closed or not. (1=closed; 0=not closed)
; If NODE="RQST2", we are checking the domain that sent the request.
; If NODE="ATHR2", we are checking the domain to which we are sending
; the request. If the domain is closed, then the transaction is marked
; for purging.
Q:'$$CLOSED($P($G(^VAT(394.61,TRANDA,NODE)),U,2)) 0
D SETPURGE(TRANDA)
Q 1
CLOSED(DOMAIN) ; Function, given domain name, returns whether the domain
; is closed or not. 1=closed; 0=not closed
N VIEN
S VIEN=$$FIND1^DIC(4.2,"","MQX",DOMAIN,"B^C") Q:'VIEN 0
Q $P($G(^DIC(4.2,VIEN,0)),U,2)["C"
SETPURGE(TRANDA) ;
N VFDA
S VFDA(394.61,TRANDA_",",90)=1 ; set purge flag
D FILE^DIE("","VFDA")
Q
;
GETINST(DOMAIN) ;-- Return name of institution for domain
;
; INPUT: DOMAIN -
; OUTPUT: NULL - ERROR
; INSTITUTION - SUCCESS
;
N DOMNO,INSTDA,STNO,INST
;
;W !,"Domain = ",DOMAIN
Q:'$D(DOMAIN) ""
;
S DOMNO=+$$FIND1^DIC(4.2,"","BMX",DOMAIN,"B^C","","ERROR")
Q:DOMNO=0 ""
S INSTDA=$P($G(^DIC(4.2,DOMNO,0)),U,13) Q:INSTDA="" ""
S STNO="",STNO=$O(^DIC(4,"D",INSTDA,"")) Q:STNO="" ""
S INST=$P($G(^DIC(4,STNO,0)),U,1)
Q:INST="" ""
Q INST
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQUTL97 3621 printed Oct 16, 2024@18:27:48 Page 2
VAQUTL97 ;ALB/JFP,JRP - PDX Patient Lookup ;24-JAN-93
+1 ;;1.5;PATIENT DATA EXCHANGE;**2,9,29,35**;NOV 17, 1993
+2 ;
GETDFN(PATIENT,TASK) ;-- Return DFN of patient
+1 ; -- This will return the same information that DIC returns in Y
+2 NEW DIC,X,Y,RESULT,USRABORT
+3 SET USRABORT=-1
+4 if '$DATA(PATIENT)
SET PATIENT=""
+5 if '$DATA(TASK)
SET TASK=0
+6 ; -- User interface
+7 SET DIC(0)="M"
+8 IF (PATIENT="")&('TASK)
SET DIC(0)=DIC(0)_"A"
+9 IF (PATIENT="")&(TASK)
SET RESULT=USRABORT
QUIT RESULT
+10 if TASK
SET DIC(0)=DIC(0)_"XZ"
+11 if 'TASK
SET DIC(0)=DIC(0)_"EQZ"
+12 SET X=PATIENT
+13 SET DIC="^DPT("
+14 ; -- Prevent sensitive record bulletin if called in TASK mode
+15 if (TASK)
SET DGSENFLG=""
+16 DO ^DIC
+17 KILL DGSENFLG
+18 ; -- User aborted process
+19 if $DATA(DTOUT)
QUIT USRABORT
+20 if $DATA(DUOUT)
QUIT USRABORT
+21 QUIT Y
+22 ;
GETSEN(DFN) ; -- Returns code for sensitive patient or not
+1 ; INPUT: DFN = Dictionary file number
+2 ; OUTPUT: 1 = Sensitive patient
+3 ; 0 = Non sensitive
+4 ; -1 = Bad input
+5 ;
+6 if '$DATA(DFN)
QUIT -1
+7 if DFN=""
QUIT -1
+8 if DFN=0
QUIT -1
+9 ; -- not sensitive patient
if '$DATA(^DGSL(38.1,DFN,0))
QUIT -0
+10 ; -- 1 SENSITIVE, 0 NON-SENSITIVE
QUIT $PIECE($GET(^DGSL(38.1,DFN,0)),U,2)
+11 ;
EXPTRN(TRANDA) ; -- Determines if any entry in the transactions file is
+1 ; marked for purge or exceed the life days.
+2 ; Also checks to make sure that requesting domain is
+3 ; not closed. If it is, it marks the transaction file
+4 ; entry for purging.
+5 ; INPUT : TRANDA DA TO TRANSACTION RECORD
+6 ; OUTOUT: -1 error in data
+7 ; 0 not expired
+8 ; 1 expired
+9 ;
+10 NEW X,LDAY,PURGE
+11 SET PURGE=$PIECE($GET(^VAT(394.61,TRANDA,"PRG")),U,1)
+12 ; -- purge flag set
IF PURGE=1
QUIT 1
+13 ;
+14 ; -- Current date
SET X1=$$NOW^VAQUTL99(1,1)
+15 SET X2=$PIECE($GET(^VAT(394.61,TRANDA,"ATHR1")),U,1)
+16 IF X2=""
SET X2=$PIECE($GET(^VAT(394.61,TRANDA,"RQST1")),U,1)
+17 SET X2=$PIECE(X2,".",1)
+18 ; -- error in data
IF X2=""
QUIT -1
+19 ;
+20 SET LDAY=$PIECE($GET(^VAT(394.81,1,"LIFE")),U,1)
+21 ; -- no life days set
IF LDAY=""
QUIT 0
+22 ;
+23 DO ^%DTC
+24 ; -- Expired
IF X>LDAY
QUIT 1
+25 QUIT 0
CLOSDOM(TRANDA,DOMAIN) ; Function, given domain, returns whether
+1 ; the domain is closed or not. (1=closed; 0=not closed)
+2 ; If the domain is closed, then the transaction is marked for purging.
+3 if '$$CLOSED(DOMAIN)
QUIT 0
+4 DO SETPURGE(TRANDA)
+5 QUIT 1
CLOSTRAN(TRANDA,NODE) ; Function, given transaction number, returns whether
+1 ; the domain is closed or not. (1=closed; 0=not closed)
+2 ; If NODE="RQST2", we are checking the domain that sent the request.
+3 ; If NODE="ATHR2", we are checking the domain to which we are sending
+4 ; the request. If the domain is closed, then the transaction is marked
+5 ; for purging.
+6 if '$$CLOSED($PIECE($GET(^VAT(394.61,TRANDA,NODE)),U,2))
QUIT 0
+7 DO SETPURGE(TRANDA)
+8 QUIT 1
CLOSED(DOMAIN) ; Function, given domain name, returns whether the domain
+1 ; is closed or not. 1=closed; 0=not closed
+2 NEW VIEN
+3 SET VIEN=$$FIND1^DIC(4.2,"","MQX",DOMAIN,"B^C")
if 'VIEN
QUIT 0
+4 QUIT $PIECE($GET(^DIC(4.2,VIEN,0)),U,2)["C"
SETPURGE(TRANDA) ;
+1 NEW VFDA
+2 ; set purge flag
SET VFDA(394.61,TRANDA_",",90)=1
+3 DO FILE^DIE("","VFDA")
+4 QUIT
+5 ;
GETINST(DOMAIN) ;-- Return name of institution for domain
+1 ;
+2 ; INPUT: DOMAIN -
+3 ; OUTPUT: NULL - ERROR
+4 ; INSTITUTION - SUCCESS
+5 ;
+6 NEW DOMNO,INSTDA,STNO,INST
+7 ;
+8 ;W !,"Domain = ",DOMAIN
+9 if '$DATA(DOMAIN)
QUIT ""
+10 ;
+11 SET DOMNO=+$$FIND1^DIC(4.2,"","BMX",DOMAIN,"B^C","","ERROR")
+12 if DOMNO=0
QUIT ""
+13 SET INSTDA=$PIECE($GET(^DIC(4.2,DOMNO,0)),U,13)
if INSTDA=""
QUIT ""
+14 SET STNO=""
SET STNO=$ORDER(^DIC(4,"D",INSTDA,""))
if STNO=""
QUIT ""
+15 SET INST=$PIECE($GET(^DIC(4,STNO,0)),U,1)
+16 if INST=""
QUIT ""
+17 QUIT INST
+18 ;
