BPCALRG.m

BPCALRG ; IHS/OIT/MJL - ALLERGY TRACKING RPC ROUTINE - FHL ;

 ;;1.5;BPC;;MAY 26, 2005

GETALRG(BPCRES,BPCIEN) ;EP REMOTE PROC: BPC GETALLERG

 ;

 S U="^",XWBWRAP=1,BPCCTR=0,BPCSUB=$J,BPCIEN=$G(BPCIEN),BPCRES="^BPCRES("_BPCSUB_")"

 K ^BPCRES($J)

 I BPCIEN="" S ^BPCRES($J,0)=-1,^BPCRES($J,1)="NO PATIENT IEN SENT. UNABLE TO GET ALLERGIES!" D KILL Q

 D GETAL,KILL

 Q

GETAL ;

 I '$D(^GMR(120.8,"B",BPCIEN)) S ^BPCRES($J,0)=1,^BPCRES($J,1)="No Allergies Noted" Q

 S BPCX="",BPCSTOP=0 F  S BPCX=$O(^GMR(120.8,"B",BPCIEN,BPCX)) Q:BPCX=""  D  Q:BPCSTOP

 .S BPCDTA=^GMR(120.8,BPCX,0),BPCAGENT=$P(BPCDTA,U,2)

 .I BPCAGENT="" S BPCKAL=$P(BPCDTA,U,22) D  Q

 ..I BPCKAL="n" S BPCSTOP=1,^BPCRES($J,0)=1,^BPCRES($J,1)="No Known Allergies"

 .S BPCTYPE="",BPCTYP=$P(BPCDTA,U,20) I BPCTYP'="" D

 ..F BPCY=1:1:$L(BPCTYP) S BPCTYPE=$S(BPCY=1:"",1:BPCTYPE_",")_$S($E(BPCTYP,BPCY)="D":"DRUG",$E(BPCTYP,BPCY)="F":"FOOD",1:"OTHER")

 .S BPCOH=$P(BPCDTA,U,6),BPCOHD="" I BPCOH'="" D

 ..I BPCOH="h" S BPCOHD="HISTORICAL" Q

 ..I BPCOH="o" S BPCOHD="OBSERVED"

 .S BPCDATE=$P(BPCDTA,U,4),BPCDATE=$P(BPCDATE,".",1)

 .S BPCCTR=BPCCTR+1,^BPCRES($J,BPCCTR)=BPCAGENT_"`"_BPCTYPE_"`"_BPCOHD_"`"_BPCDATE_"`"_BPCX

 S ^BPCRES($J,0)=BPCCTR

 Q

KILL ;

 K BPCCTR,BPCSUB,BPCX,BPCSTOP,BPCKAL,BPCTYP,BPCTYPE,BPCY

 Q

BPCALRG   ; IHS/OIT/MJL - ALLERGY TRACKING RPC ROUTINE - FHL ;

 +1       ;;1.5;BPC;;MAY 26, 2005

GETALRG(BPCRES,BPCIEN) ;EP REMOTE PROC: BPC GETALLERG

 +1       ;

 +2        SET U="^"

           SET XWBWRAP=1

           SET BPCCTR=0

           SET BPCSUB=$JOB

           SET BPCIEN=$GET(BPCIEN)

           SET BPCRES="^BPCRES("_BPCSUB_")"

 +3        KILL ^BPCRES($JOB)

 +4        IF BPCIEN=""

               SET ^BPCRES($JOB,0)=-1

               SET ^BPCRES($JOB,1)="NO PATIENT IEN SENT. UNABLE TO GET ALLERGIES!"

               DO KILL

               QUIT 

 +5        DO GETAL

           DO KILL

 +6        QUIT 

GETAL     ;

 +1        IF '$DATA(^GMR(120.8,"B",BPCIEN))

               SET ^BPCRES($JOB,0)=1

               SET ^BPCRES($JOB,1)="No Allergies Noted"

               QUIT 

 +2        SET BPCX=""

           SET BPCSTOP=0

           FOR 

               SET BPCX=$ORDER(^GMR(120.8,"B",BPCIEN,BPCX))

               IF BPCX=""

                   QUIT 

               Begin DoDot:1

 +3                SET BPCDTA=^GMR(120.8,BPCX,0)

                   SET BPCAGENT=$PIECE(BPCDTA,U,2)

 +4                IF BPCAGENT=""

                       SET BPCKAL=$PIECE(BPCDTA,U,22)

                       Begin DoDot:2

 +5                        IF BPCKAL="n"

                               SET BPCSTOP=1

                               SET ^BPCRES($JOB,0)=1

                               SET ^BPCRES($JOB,1)="No Known Allergies"

                       End DoDot:2

                       QUIT 

 +6                SET BPCTYPE=""

                   SET BPCTYP=$PIECE(BPCDTA,U,20)

                   IF BPCTYP'=""

                       Begin DoDot:2

 +7                        FOR BPCY=1:1:$LENGTH(BPCTYP)

                               SET BPCTYPE=$SELECT(BPCY=1:"",1:BPCTYPE_",")_$SELECT($EXTRACT(BPCTYP,BPCY)="D":"DRUG",$EXTRACT(BPCTYP,BPCY)="F":"FOOD",1:"OTHER")

                       End DoDot:2

 +8                SET BPCOH=$PIECE(BPCDTA,U,6)

                   SET BPCOHD=""

                   IF BPCOH'=""

                       Begin DoDot:2

 +9                        IF BPCOH="h"

                               SET BPCOHD="HISTORICAL"

                               QUIT 

 +10                       IF BPCOH="o"

                               SET BPCOHD="OBSERVED"

                       End DoDot:2

 +11               SET BPCDATE=$PIECE(BPCDTA,U,4)

                   SET BPCDATE=$PIECE(BPCDATE,".",1)

 +12               SET BPCCTR=BPCCTR+1

                   SET ^BPCRES($JOB,BPCCTR)=BPCAGENT_"`"_BPCTYPE_"`"_BPCOHD_"`"_BPCDATE_"`"_BPCX

               End DoDot:1

               IF BPCSTOP

                   QUIT 

 +13       SET ^BPCRES($JOB,0)=BPCCTR

 +14       QUIT 

KILL      ;

 +1        KILL BPCCTR,BPCSUB,BPCX,BPCSTOP,BPCKAL,BPCTYP,BPCTYPE,BPCY

 +2        QUIT