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