- APSPESAL ;IHS/MSC/MGH;20-Aug-2012 15:36;DU;DU
- ;;7.0;IHS PHARMACY MODIFICATIONS;**1016**;Sep 23, 2004;Build 74
- ;================================================================
- ;Return var TYPE = 11th piece From 120.8-0,P20) (FA,DA,MA)
- ; Allergy = 3rd (From 120.8-0,p3)
- ; Severity = 9th (From 120.85-0,P14)
- ; Reaction = 10th (From 120.8-10,P1->120.83)
- ; ID Date = 4th (From 120.85-0,P1) $$HLDATE^HLFNC(DT)
- ; msc/gjg modified 3/2/11 - artf11068
- ; msc/ses modified 5/22/12 - artf12697
- Q
- GETADR(RESULT,DFN,ALL,AL1) ;get adverse reaction
- K RESULT N B,I,EIE,HASAL,CNT,INAC,C,J,K,PCNT,TIDDT,TATYPE,TI,TT,ZERO
- S HASAL=0,EIE=0
- I '$D(^DPT(+$G(DFN),0)) S RESULT(1)="-1^INVALID PATIENT" Q
- ;go through allergies.
- S CNT=0
- F I=0:0 S I=$O(^GMR(120.8,"B",DFN,I)) Q:'I S ZERO=$G(^GMR(120.8,I,0)),EIE=+$G(^("ER")) D
- .Q:+EIE ; Do not send entered in error Allergies
- .I 'EIE S HASAL=1
- .S INAC=$$INACTIVE^GMRADSP6(I)
- .I INAC=1,ALL="A" Q ;Not active
- .S (B,C)=""
- .S B=$$GET1^DIQ(120.8,I,"GMR ALLERGY"),PCNT=CNT
- .F J=0:0 S J=$O(^GMR(120.8,I,10,J)) Q:'J S ZERO(1)=$P(^GMRD(120.83,+$G(^(J,0)),0),U),C=C_$P(ZERO(1),U)_","
- .F K=0:0 S K=$O(^GMR(120.85,"C",I,K)) Q:'K S ZERO(2)=$G(^GMR(120.85,+K,0)) D ADR
- .I CNT=PCNT S ZERO(2)="" D ADR ;no adversion reporting
- I ('HASAL)&($P($G(^GMR(120.86,+DFN,0)),U,2)=0) S ZERO=$G(^(0)) D
- . K RESULT
- . S RESULT=0,AL1=0
- Q
- ADR S CNT=CNT+1
- S TIDDT=$$HLDATE^HLFNC($P(ZERO,U,4))
- S TATYPE=$P(ZERO,U,20),TT=""
- F TI=1:1:$L(TATYPE) S $P(TT,"~",TI)=$S($E(TATYPE,TI)="D":"DA",$E(TATYPE,TI)="F":"FA",$E(TATYPE,TI)="O":"MA",1:"")
- S TATYPE=TT
- ; 1st, 2nd, 3rd, 4th, 5th
- S RESULT(CNT)=I_U_$S(B=$P(ZERO,U,2):$P(ZERO,U,3),1:"")_U_$P(ZERO,U,2)_U_TIDDT_U_$S(B=$P(ZERO,U,2):0,1:1)
- ; 6th, 7th, 8th
- S RESULT(CNT)=RESULT(CNT)_U_$P(ZERO,U,14)_U_$S($P(ZERO,U,16):"VERIFIED",1:"")_U_EIE
- ; 9th,10th,11th
- S RESULT(CNT)=RESULT(CNT)_U_$P("MI^MO^SV",U,$P(ZERO(2),U,14))_U_$E(C,1,$L(C)-1)_U_TATYPE
- Q
- APSPESAL ;IHS/MSC/MGH;20-Aug-2012 15:36;DU;DU
- +1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1016**;Sep 23, 2004;Build 74
- +2 ;================================================================
- +3 ;Return var TYPE = 11th piece From 120.8-0,P20) (FA,DA,MA)
- +4 ; Allergy = 3rd (From 120.8-0,p3)
- +5 ; Severity = 9th (From 120.85-0,P14)
- +6 ; Reaction = 10th (From 120.8-10,P1->120.83)
- +7 ; ID Date = 4th (From 120.85-0,P1) $$HLDATE^HLFNC(DT)
- +8 ; msc/gjg modified 3/2/11 - artf11068
- +9 ; msc/ses modified 5/22/12 - artf12697
- +10 QUIT
- GETADR(RESULT,DFN,ALL,AL1) ;get adverse reaction
- +1 KILL RESULT
- NEW B,I,EIE,HASAL,CNT,INAC,C,J,K,PCNT,TIDDT,TATYPE,TI,TT,ZERO
- +2 SET HASAL=0
- SET EIE=0
- +3 IF '$DATA(^DPT(+$GET(DFN),0))
- SET RESULT(1)="-1^INVALID PATIENT"
- QUIT
- +4 ;go through allergies.
- +5 SET CNT=0
- +6 FOR I=0:0
- SET I=$ORDER(^GMR(120.8,"B",DFN,I))
- IF 'I
- QUIT
- SET ZERO=$GET(^GMR(120.8,I,0))
- SET EIE=+$GET(^("ER"))
- Begin DoDot:1
- +7 ; Do not send entered in error Allergies
- IF +EIE
- QUIT
- +8 IF 'EIE
- SET HASAL=1
- +9 SET INAC=$$INACTIVE^GMRADSP6(I)
- +10 ;Not active
- IF INAC=1
- IF ALL="A"
- QUIT
- +11 SET (B,C)=""
- +12 SET B=$$GET1^DIQ(120.8,I,"GMR ALLERGY")
- SET PCNT=CNT
- +13 FOR J=0:0
- SET J=$ORDER(^GMR(120.8,I,10,J))
- IF 'J
- QUIT
- SET ZERO(1)=$PIECE(^GMRD(120.83,+$GET(^(J,0)),0),U)
- SET C=C_$PIECE(ZERO(1),U)_","
- +14 FOR K=0:0
- SET K=$ORDER(^GMR(120.85,"C",I,K))
- IF 'K
- QUIT
- SET ZERO(2)=$GET(^GMR(120.85,+K,0))
- DO ADR
- +15 ;no adversion reporting
- IF CNT=PCNT
- SET ZERO(2)=""
- DO ADR
- End DoDot:1
- +16 IF ('HASAL)&($PIECE($GET(^GMR(120.86,+DFN,0)),U,2)=0)
- SET ZERO=$GET(^(0))
- Begin DoDot:1
- +17 KILL RESULT
- +18 SET RESULT=0
- SET AL1=0
- End DoDot:1
- +19 QUIT
- ADR SET CNT=CNT+1
- +1 SET TIDDT=$$HLDATE^HLFNC($PIECE(ZERO,U,4))
- +2 SET TATYPE=$PIECE(ZERO,U,20)
- SET TT=""
- +3 FOR TI=1:1:$LENGTH(TATYPE)
- SET $PIECE(TT,"~",TI)=$SELECT($EXTRACT(TATYPE,TI)="D":"DA",$EXTRACT(TATYPE,TI)="F":"FA",$EXTRACT(TATYPE,TI)="O":"MA",1:"")
- +4 SET TATYPE=TT
- +5 ; 1st, 2nd, 3rd, 4th, 5th
- +6 SET RESULT(CNT)=I_U_$SELECT(B=$PIECE(ZERO,U,2):$PIECE(ZERO,U,3),1:"")_U_$PIECE(ZERO,U,2)_U_TIDDT_U_$SELECT(B=$PIECE(ZERO,U,2):0,1:1)
- +7 ; 6th, 7th, 8th
- +8 SET RESULT(CNT)=RESULT(CNT)_U_$PIECE(ZERO,U,14)_U_$SELECT($PIECE(ZERO,U,16):"VERIFIED",1:"")_U_EIE
- +9 ; 9th,10th,11th
- +10 SET RESULT(CNT)=RESULT(CNT)_U_$PIECE("MI^MO^SV",U,$PIECE(ZERO(2),U,14))_U_$EXTRACT(C,1,$LENGTH(C)-1)_U_TATYPE
- +11 QUIT
