APSPESAL.m

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