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