Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VAQDBIP1

VAQDBIP1.m

Go to the documentation of this file. 
  1. VAQDBIP1 ;ALB/JRP - PHARMACY EXTRACTION;16-MAR-93
  1.  ;;1.5;PATIENT DATA EXCHANGE;**31**;NOV 17, 1993
  1. RXXTRCT(TRAN,DFN,ARRAY,CUTOFF) ;EXTRACT PHARMACY INFORMATION
  1.  ;INPUT  : TRAN - Pointer to VAQ - TRANSACTION file
  1.  ;          DFN - Pointer to patient in PATIENT file
  1.  ;         ARRAY - Where to store information (full global reference)
  1.  ;         CUTOFF - Number of days to cut off expired/canceled RXs
  1.  ;                  (defaults to 90)
  1.  ;OUTPUT : 0 - Extraction was successfull
  1.  ;        -1^Error_Text - Extraction was not successfull
  1.  ;NOTE   : If the pharmacy information can not be extracted,
  1.  ;         the "VALUE" and "ID" nodes in ARRAY will be deleted.
  1.  ;       : If TRAN is passed
  1.  ;           The patient pointer of the transaction will be used
  1.  ;           Encryption will be based on the transaction
  1.  ;         If DFN is passed
  1.  ;           Encryption will be based on the site parameter
  1.  ;       : Pointer to transaction takes precedence over DFN ... if
  1.  ;         TRAN>0 the DFN will be based on the transaction
  1.  ;
  1.  ;CHECK INPUT
  1.  S TRAN=+$G(TRAN)
  1.  S DFN=+$G(DFN)
  1.  Q:(('TRAN)&('DFN)) "-1^Did not pass pointer to transaction or patient"
  1.  I (TRAN) Q:('$D(^VAT(394.61,TRAN))) "-1^Did not pass valid pointer to VAQ - TRANSACTION file"
  1.  I (TRAN) S DFN=+$P($G(^VAT(394.61,TRAN,0)),"^",3) Q:('DFN) "-1^Transaction did not contain pointer to PATIENT file"
  1.  Q:('$D(^DPT(DFN))) "-1^Did not pass valid pointer to PATIENT file"
  1.  Q:($G(ARRAY)="") "-1^Did not pass output array"
  1.  S:('$D(CUTOFF)) CUTOFF=90
  1.  S CUTOFF=+$G(CUTOFF)
  1.  ;DECLARE VARIABLES
  1.  N TMP,LOOP,ERROR,X1,X2,X,CUTDATE,RXIFN,SEQ,ENCRYPT,DECRYPT
  1.  N J,RX0,RX2,RX3,ST,ST0,ZII,Y,%DT,GMRAL,GMRA,ENCSTR
  1.  N DECSTR,STRING,ENCPTR,KEY1,KEY2,SENDER
  1.  S ERROR=0
  1.  ;DETERMINE IF ENCRYPTION IS ON - SAVE POINTER TO ENCRYPTION METHOD
  1.  S:('TRAN) ENCPTR=$$NCRYPTON^VAQUTL2(0)
  1.  S:(TRAN) ENCPTR=$$TRANENC^VAQUTL3(TRAN,1)
  1.  ;SET UP EXECUTABLE CALL TO ENCRYPT
  1.  S:(ENCPTR) ENCRYPT=$$ENCMTHD^VAQUTL2(ENCPTR,0)
  1.  S:('ENCPTR) ENCRYPT=""
  1.  S:(ENCRYPT'="") ENCRYPT=("S ENCSTR="_ENCRYPT)
  1.  S:(ENCRYPT="") ENCRYPT="S ENCSTR=STRING"
  1.  ;SET UP EXECUTABLE CALL TO DECRYPT
  1.  S:(ENCPTR) DECRYPT=$$ENCMTHD^VAQUTL2(ENCPTR,1)
  1.  S:('ENCPTR) DECRYPT=""
  1.  S:(DECRYPT'="") DECRYPT=("S DECSTR="_DECRYPT)
  1.  S:(DECRYPT="") DECRYPT="S DECSTR=STRING"
  1.  ;DETERMINE PRIMARY KEY
  1.  I (TRAN) S SENDER=$$SENDER^VAQCON2(TRAN) Q:($P(SENDER,"^",1)="-1") "-1^Could not determine encryption keys"
  1.  S:(TRAN) SENDER=$P(SENDER,"^",1)
  1.  S:(TRAN) KEY1=$$NAMEKEY^VAQUTL3(SENDER,1)
  1.  S:('TRAN) KEY1=$$DUZKEY^VAQUTL3($G(DUZ),1)
  1.  ;DETERMINE SECONDARY KEY
  1.  S:(TRAN) KEY2=$$NAMEKEY^VAQUTL3(SENDER,0)
  1.  S:('TRAN) KEY2=$$DUZKEY^VAQUTL3($G(DUZ),0)
  1.  I (ENCPTR) Q:((KEY1="")!(KEY2="")) "-1^Could not determine encryption keys"
  1.  ;EXTRACT NON-PRESCRIPTION INFO
  1.  F LOOP=1:1 D  Q:(ERROR)
  1.  .S TMP=$T(RXPAT+LOOP^VAQDBII1)
  1.  .I ($P(TMP,";;",2)="") S ERROR=1 Q
  1.  .S ERROR=$$XTRCT^VAQDBIP2(TMP,DFN,"",ARRAY,ENCPTR,KEY1,KEY2)
  1.  .I ERROR D  Q
  1.  ..S TMP=$$KILLARR^VAQUTL1(ARRAY,"VALUE")
  1.  ..S TMP=$$KILLARR^VAQUTL1(ARRAY,"ID")
  1.  Q:(ERROR<0) ERROR
  1.  ;EXTRACT ALLERGIES & ADVERSE REACTIONS
  1.  ;(LOCATION OF INFO IS IN TRANSITION; USE SUPPORTED CALL)
  1.  S GMRA="0^0^111"
  1.  D EN1^GMRADPT
  1.  ;MOVE ALLERGIES & REACTIONS INTO EXTRACTION ARRAY
  1.  S ERROR=0
  1.  I $D(GMRAL) D
  1.  .;PATIENT IS IDENTIFIER
  1.  .S ERROR=$$PATINFO^VAQUTL1(DFN)
  1.  .S STRING=$P(ERROR,"^",1)
  1.  .Q:(STRING="-1")
  1.  .;ENCRYPT PATIENT NAME
  1.  .S ENCSTR=STRING
  1.  .I $$NCRPFLD^VAQUTL2(2,.01) X ENCRYPT
  1.  .S TMP=ENCSTR
  1.  .S ERROR=0
  1.  .; Before GMRA*4*10, if patient had NKA (no known allergies) EN1^GMRADPT
  1.  .; returned GMRAL=0 and GMRAL(<ptr to file 120.8>)=DFN_"^NKA^0^1"
  1.  .; After that patch, it just returned GMRAL=0.  So we must dummy up
  1.  .; the missing array element to make this routine work as it had before.
  1.  .I GMRAL=0,'$O(GMRAL(0)) S GMRAL(1)="^NKA" ; VAQ*1.5*31
  1.  .S GMRA=""
  1.  .F SEQ=0:1 D  Q:(GMRA="")
  1.  ..S GMRA=$O(GMRAL(GMRA))
  1.  ..Q:(GMRA="")
  1.  ..S J=$P(GMRAL(GMRA),"^",2)
  1.  ..Q:(J="")
  1.  ..;ENCRYPT VALUE
  1.  ..S STRING=J
  1.  ..S ENCSTR=STRING
  1.  ..I $$NCRPFLD^VAQUTL2(120.8,.02) X ENCRYPT
  1.  ..;STORE INFORMATION
  1.  ..S @ARRAY@("VALUE",120.8,.02,SEQ)=ENCSTR
  1.  ..S @ARRAY@("ID",120.8,.02,SEQ)=TMP
  1.  I ERROR D  Q ERROR
  1.  .S TMP=$$KILLARR^VAQUTL1(ARRAY,"VALUE")
  1.  .S TMP=$$KILLARR^VAQUTL1(ARRAY,"ID")
  1.  ;EXTRACT PRESCRIPTION INFORMATION
  1.  D SCRIPTS^VAQDBIP8
  1.  I ERROR D  Q ERROR
  1.  .S TMP=$$KILLARR^VAQUTL1(ARRAY,"VALUE")
  1.  .S TMP=$$KILLARR^VAQUTL1(ARRAY,"ID")
  1.  Q 0