PSUAA1 ;BIR/RDC - ALLERGY/ADVERSE EVENT EXTRACT ; 4/5/12 7:25am
;;4.0;PHARMACY BENEFITS MANAGEMENT;**10,14,20**;MARCH, 2005;Build 4
;
; Reference to file #4 supported by DBIA 10090
; Reference to file #2 supported by DBIA 10035 AND 3504
; Reference to file #120.8 supported by DBIA 10099, 2422, AND 4562
; Reference to file #120.85 supported by DBIA 10099
; Reference to file #49 supported by DBIA 432
;
EN ; *20 Fix typo
N ARTMP,DFN,EDATE,GMRA,GMRACT,GMRAL,GMREC,ICN,K,LINECNT,LINEMAX,LINETOT,MSGCNT,NPTR,OPTR,OREC,PN,PREC,RPTR,RRDT,RREC,SDATE,SSN,STATION,V,VPTR,X,Z
K PSUMKFLG
;
D INITZ
D GETRECS
D ^PSUAA2
Q
;
INITZ ;
; ** new all non-namespaced variables **
;
S SDATE=PSUSDT\1-.0001
S EDATE=PSUEDT\1+.2359
;
S LINEMAX=$$VAL^PSUTL(4.3,1,8.3)
S:LINEMAX=""!(LINEMAX>10000) LINEMAX=10000
S LINECNT=999999
S LINETOT=0
;
S PSUFAC=PSUSNDR
;
; ** get station number **
S X=$$VALI^PSUTL(4.3,1,217)
S STATION=+$$VAL^PSUTL(4,X,99)
;
; ** get run date **
S %H=$H
D YMD^%DTC
S $P(^TMP("PSUAA",$J),U,3)=X
;
;
Q ; ** end of partition initialization **
;
GETRECS ; ; ** extract reactive data **
F S SDATE=$O(^GMR(120.8,"V",SDATE)) Q:SDATE>EDATE!('SDATE) D
. S VPTR="" ;*** loop through verified dates ***
. F S VPTR=$O(^GMR(120.8,"V",SDATE,VPTR)) Q:VPTR="" D
.. K GMRACT,GMRAL,GMREC
.. S PSUMKFLG=0
.. S VREC=^GMR(120.8,VPTR,0)
.. S DFN=$P(VREC,U)
.. Q:$G(DFN)=""
.. Q:$$TESTPAT^VADPT(DFN)=1 ;test patient
.. S PREC=$G(^DPT(DFN,0))
.. S SSN=$P(PREC,U,9)
.. S GMRA="0^1^111"
.. D EN1^GMRADPT
.. Q:'$D(GMRAL(VPTR))
.. S GMREC=GMRAL(VPTR)
.. D EN1^GMRAOR2(VPTR,.ARTMP) ; ** load multiple variables **
.. S Z="$",OREC=""
.. D STATIC
.. S V="" F S V=$O(GMRACT("S",V)) Q:V=""!(V=7) D
... S $P(OREC,Z,13+V)=$G(GMRACT("S",V)) ; * symptoms
.. S $P(OREC,Z,20)=""
.. S V="" F S V=$O(GMRACT("O",V)) Q:V=""!(V=7) D
... S $P(OREC,Z,12)=$P(GMRACT("O",V),U) ; * event date
... S $P(OREC,Z,13)=$P(GMRACT("O",V),U,2) ; * severity
... ;PSU*4*14 add reverse translation.
... D MAKE1 S PSUMKFLG=1,OREC=$TR(OREC,"^",Z)
.. D:'$G(PSUMKFLG) MAKE1 ; ** load ^XTMP with OREC **
.. S:$G(MSGCNT) ^XTMP("PSU_"_PSUJOB,"PSUAA","MSGTCNT")=MSGCNT
.. S:LINECNT=999999 LINECNT=1
.. S:$G(LINECNT) ^XTMP("PSU_"_PSUJOB,"PSUAA","LINECNT")=LINECNT
Q
;
STATIC ; ** set static pieces of record into OREC **
;
S $P(OREC,Z,1)=""
S $P(OREC,Z,2)=STATION_VPTR ; ** event ID
S $P(OREC,Z,3)=SSN ; ** social security #
;
S ICN=$$GETICN^MPIF001(DFN) ; ** ICN
I $E(ICN,1,2)="-1" S ICN=""
S $P(OREC,Z,4)=ICN
;
S $P(OREC,Z,5)=$P(GMREC,U,2) ; ** reactant
S $P(OREC,Z,6)=$P($P($P(GMREC,U,9),"(",2),",") ; * reactant file #
S $P(OREC,Z,7)=$P(GMREC,U,7) ; ** allergy type
S $P(OREC,Z,8)=$P(VREC,U,4) ; ** origination date
;
S NPTR=$P(VREC,U,5) ; * originator's section/service
I NPTR S OPTR=$P($G(^VA(200,NPTR,5)),U,1)
I OPTR S $P(OREC,Z,9)=$P(^DIC(49,OPTR,0),U,1)
;
S $P(OREC,Z,10)=$P(VREC,U,6) ; ** observed/historical
S $P(OREC,Z,11)=$P(VREC,U,14) ; ** mechanism
;
Q ; ** end of static variables for a message **
;
MAKE1 ; ** load one record/message **
;
S OREC=$TR(OREC,"^","'")
S OREC=$TR(OREC,Z,U)
;
S LINECNT=LINECNT+1
S LINETOT=LINETOT+1
I LINECNT>LINEMAX S MSGCNT=$G(MSGCNT)+1,LINECNT=1
I $L(OREC)<254 S ^XTMP("PSU_"_PSUJOB,"PSUAA",MSGCNT,LINECNT)=OREC Q
;PSU*4*14 Add infinite loop safety.
F K=254:-1:0 Q:$E(OREC,K)="^"
S ^XTMP("PSU_"_PSUJOB,"PSUAA",MSGCNT,LINECNT)=$E(OREC,1,K)
S LINECNT=LINECNT+1
S LINETOT=LINETOT+1
;*20 Remove duplicate "^" from $E
S ^XTMP("PSU_"_PSUJOB,"PSUAA",MSGCNT,LINECNT)="*"_$E(OREC,K+1,K+253)
Q
PRINT ; *20 Update Comment
; Printing of Allergies/Adverse Events.
; Called from PSUCP. No longer used.
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUAA1 4071 printed Sep 23, 2025@20:02:56 Page 2
PSUAA1 ;BIR/RDC - ALLERGY/ADVERSE EVENT EXTRACT ; 4/5/12 7:25am
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**10,14,20**;MARCH, 2005;Build 4
+2 ;
+3 ; Reference to file #4 supported by DBIA 10090
+4 ; Reference to file #2 supported by DBIA 10035 AND 3504
+5 ; Reference to file #120.8 supported by DBIA 10099, 2422, AND 4562
+6 ; Reference to file #120.85 supported by DBIA 10099
+7 ; Reference to file #49 supported by DBIA 432
+8 ;
EN ; *20 Fix typo
+1 NEW ARTMP,DFN,EDATE,GMRA,GMRACT,GMRAL,GMREC,ICN,K,LINECNT,LINEMAX,LINETOT,MSGCNT,NPTR,OPTR,OREC,PN,PREC,RPTR,RRDT,RREC,SDATE,SSN,STATION,V,VPTR,X,Z
+2 KILL PSUMKFLG
+3 ;
+4 DO INITZ
+5 DO GETRECS
+6 DO ^PSUAA2
+7 QUIT
+8 ;
INITZ ;
+1 ; ** new all non-namespaced variables **
+2 ;
+3 SET SDATE=PSUSDT\1-.0001
+4 SET EDATE=PSUEDT\1+.2359
+5 ;
+6 SET LINEMAX=$$VAL^PSUTL(4.3,1,8.3)
+7 if LINEMAX=""!(LINEMAX>10000)
SET LINEMAX=10000
+8 SET LINECNT=999999
+9 SET LINETOT=0
+10 ;
+11 SET PSUFAC=PSUSNDR
+12 ;
+13 ; ** get station number **
+14 SET X=$$VALI^PSUTL(4.3,1,217)
+15 SET STATION=+$$VAL^PSUTL(4,X,99)
+16 ;
+17 ; ** get run date **
+18 SET %H=$HOROLOG
+19 DO YMD^%DTC
+20 SET $PIECE(^TMP("PSUAA",$JOB),U,3)=X
+21 ;
+22 ;
+23 ; ** end of partition initialization **
QUIT
+24 ;
GETRECS ; ; ** extract reactive data **
+1 FOR
SET SDATE=$ORDER(^GMR(120.8,"V",SDATE))
if SDATE>EDATE!('SDATE)
QUIT
Begin DoDot:1
+2 ;*** loop through verified dates ***
SET VPTR=""
+3 FOR
SET VPTR=$ORDER(^GMR(120.8,"V",SDATE,VPTR))
if VPTR=""
QUIT
Begin DoDot:2
+4 KILL GMRACT,GMRAL,GMREC
+5 SET PSUMKFLG=0
+6 SET VREC=^GMR(120.8,VPTR,0)
+7 SET DFN=$PIECE(VREC,U)
+8 if $GET(DFN)=""
QUIT
+9 ;test patient
if $$TESTPAT^VADPT(DFN)=1
QUIT
+10 SET PREC=$GET(^DPT(DFN,0))
+11 SET SSN=$PIECE(PREC,U,9)
+12 SET GMRA="0^1^111"
+13 DO EN1^GMRADPT
+14 if '$DATA(GMRAL(VPTR))
QUIT
+15 SET GMREC=GMRAL(VPTR)
+16 ; ** load multiple variables **
DO EN1^GMRAOR2(VPTR,.ARTMP)
+17 SET Z="$"
SET OREC=""
+18 DO STATIC
+19 SET V=""
FOR
SET V=$ORDER(GMRACT("S",V))
if V=""!(V=7)
QUIT
Begin DoDot:3
+20 ; * symptoms
SET $PIECE(OREC,Z,13+V)=$GET(GMRACT("S",V))
End DoDot:3
+21 SET $PIECE(OREC,Z,20)=""
+22 SET V=""
FOR
SET V=$ORDER(GMRACT("O",V))
if V=""!(V=7)
QUIT
Begin DoDot:3
+23 ; * event date
SET $PIECE(OREC,Z,12)=$PIECE(GMRACT("O",V),U)
+24 ; * severity
SET $PIECE(OREC,Z,13)=$PIECE(GMRACT("O",V),U,2)
+25 ;PSU*4*14 add reverse translation.
+26 DO MAKE1
SET PSUMKFLG=1
SET OREC=$TRANSLATE(OREC,"^",Z)
End DoDot:3
+27 ; ** load ^XTMP with OREC **
if '$GET(PSUMKFLG)
DO MAKE1
+28 if $GET(MSGCNT)
SET ^XTMP("PSU_"_PSUJOB,"PSUAA","MSGTCNT")=MSGCNT
+29 if LINECNT=999999
SET LINECNT=1
+30 if $GET(LINECNT)
SET ^XTMP("PSU_"_PSUJOB,"PSUAA","LINECNT")=LINECNT
End DoDot:2
End DoDot:1
+31 QUIT
+32 ;
STATIC ; ** set static pieces of record into OREC **
+1 ;
+2 SET $PIECE(OREC,Z,1)=""
+3 ; ** event ID
SET $PIECE(OREC,Z,2)=STATION_VPTR
+4 ; ** social security #
SET $PIECE(OREC,Z,3)=SSN
+5 ;
+6 ; ** ICN
SET ICN=$$GETICN^MPIF001(DFN)
+7 IF $EXTRACT(ICN,1,2)="-1"
SET ICN=""
+8 SET $PIECE(OREC,Z,4)=ICN
+9 ;
+10 ; ** reactant
SET $PIECE(OREC,Z,5)=$PIECE(GMREC,U,2)
+11 ; * reactant file #
SET $PIECE(OREC,Z,6)=$PIECE($PIECE($PIECE(GMREC,U,9),"(",2),",")
+12 ; ** allergy type
SET $PIECE(OREC,Z,7)=$PIECE(GMREC,U,7)
+13 ; ** origination date
SET $PIECE(OREC,Z,8)=$PIECE(VREC,U,4)
+14 ;
+15 ; * originator's section/service
SET NPTR=$PIECE(VREC,U,5)
+16 IF NPTR
SET OPTR=$PIECE($GET(^VA(200,NPTR,5)),U,1)
+17 IF OPTR
SET $PIECE(OREC,Z,9)=$PIECE(^DIC(49,OPTR,0),U,1)
+18 ;
+19 ; ** observed/historical
SET $PIECE(OREC,Z,10)=$PIECE(VREC,U,6)
+20 ; ** mechanism
SET $PIECE(OREC,Z,11)=$PIECE(VREC,U,14)
+21 ;
+22 ; ** end of static variables for a message **
QUIT
+23 ;
MAKE1 ; ** load one record/message **
+1 ;
+2 SET OREC=$TRANSLATE(OREC,"^","'")
+3 SET OREC=$TRANSLATE(OREC,Z,U)
+4 ;
+5 SET LINECNT=LINECNT+1
+6 SET LINETOT=LINETOT+1
+7 IF LINECNT>LINEMAX
SET MSGCNT=$GET(MSGCNT)+1
SET LINECNT=1
+8 IF $LENGTH(OREC)<254
SET ^XTMP("PSU_"_PSUJOB,"PSUAA",MSGCNT,LINECNT)=OREC
QUIT
+9 ;PSU*4*14 Add infinite loop safety.
+10 FOR K=254:-1:0
if $EXTRACT(OREC,K)="^"
QUIT
+11 SET ^XTMP("PSU_"_PSUJOB,"PSUAA",MSGCNT,LINECNT)=$EXTRACT(OREC,1,K)
+12 SET LINECNT=LINECNT+1
+13 SET LINETOT=LINETOT+1
+14 ;*20 Remove duplicate "^" from $E
+15 SET ^XTMP("PSU_"_PSUJOB,"PSUAA",MSGCNT,LINECNT)="*"_$EXTRACT(OREC,K+1,K+253)
+16 QUIT
PRINT ; *20 Update Comment
+1 ; Printing of Allergies/Adverse Events.
+2 ; Called from PSUCP. No longer used.
+3 QUIT
+4 ;
