PSBALL.m

PSBALL ;BIRMINGHAM/VRN-BCMA RPC BROKER CALLS ;Mar 2004

 ;;3.0;BAR CODE MED ADMIN;;Mar 2004

 ;

 ; Reference/IA

 ; EN1^GMRADPT/10099

 ;

ALLR(RESULTS,DFN) ; Return array of patient allergies/adverse reactions

 ;

 ;RPC: PSB ALLERGY

 ;

 D SORT

 Q

 ;

SORT ;*** Set up the allergies and adv. reactions arrays.

 S PSBCNT=1,(PSBALC,PSBARC)=0

 S GMRA="0^0^111" D EN1^GMRADPT

 I GMRAL="" S RESULTS(0)=1,RESULTS(1)="ALL"_U_"No Allergy Assessment" Q

 I GMRAL=0 S RESULTS(0)=1,RESULTS(1)="ALL"_U_"No Known Allergies" Q

 F X=0:0 S X=$O(GMRAL(X)) Q:'X  S PSBTYP=$P(GMRAL(X),U,5),PSBNM=$P(GMRAL(X),U,2) D

 .S:PSBTYP=0 PSBALC=PSBALC+1,PSBALG(PSBNM)=""

 .S:PSBTYP>0 PSBARC=PSBARC+1,PSBADR(PSBNM)=""

 S (X,Y)="" F  S X=$O(PSBALG(X)) Q:X=""  S Y="ALL"_U_X,RESULTS(PSBCNT)=Y,PSBCNT=PSBCNT+1

 S (X,Y)="" F  S X=$O(PSBADR(X)) Q:X=""  S Y="ADR"_U_X,RESULTS(PSBCNT)=Y,PSBCNT=PSBCNT+1

 S RESULTS(0)=PSBCNT-1

 K GMRA,GMRAL,PSBADR,PSBALC,PSBALG,PSBARC,PSBCNT,PSBNM,PSBTYP

 Q

 ;

PSBALL    ;BIRMINGHAM/VRN-BCMA RPC BROKER CALLS ;Mar 2004

 +1       ;;3.0;BAR CODE MED ADMIN;;Mar 2004

 +2       ;

 +3       ; Reference/IA

 +4       ; EN1^GMRADPT/10099

 +5       ;

ALLR(RESULTS,DFN) ; Return array of patient allergies/adverse reactions

 +1       ;

 +2       ;RPC: PSB ALLERGY

 +3       ;

 +4        DO SORT

 +5        QUIT 

 +6       ;

SORT      ;*** Set up the allergies and adv. reactions arrays.

 +1        SET PSBCNT=1

           SET (PSBALC,PSBARC)=0

 +2        SET GMRA="0^0^111"

           DO EN1^GMRADPT

 +3        IF GMRAL=""

               SET RESULTS(0)=1

               SET RESULTS(1)="ALL"_U_"No Allergy Assessment"

               QUIT 

 +4        IF GMRAL=0

               SET RESULTS(0)=1

               SET RESULTS(1)="ALL"_U_"No Known Allergies"

               QUIT 

 +5        FOR X=0:0

               SET X=$ORDER(GMRAL(X))

               IF 'X

                   QUIT 

               SET PSBTYP=$PIECE(GMRAL(X),U,5)

               SET PSBNM=$PIECE(GMRAL(X),U,2)

               Begin DoDot:1

 +6                IF PSBTYP=0

                       SET PSBALC=PSBALC+1

                       SET PSBALG(PSBNM)=""

 +7                IF PSBTYP>0

                       SET PSBARC=PSBARC+1

                       SET PSBADR(PSBNM)=""

               End DoDot:1

 +8        SET (X,Y)=""

           FOR 

               SET X=$ORDER(PSBALG(X))

               IF X=""

                   QUIT 

               SET Y="ALL"_U_X

               SET RESULTS(PSBCNT)=Y

               SET PSBCNT=PSBCNT+1

 +9        SET (X,Y)=""

           FOR 

               SET X=$ORDER(PSBADR(X))

               IF X=""

                   QUIT 

               SET Y="ADR"_U_X

               SET RESULTS(PSBCNT)=Y

               SET PSBCNT=PSBCNT+1

 +10       SET RESULTS(0)=PSBCNT-1

 +11       KILL GMRA,GMRAL,PSBADR,PSBALC,PSBALG,PSBARC,PSBCNT,PSBNM,PSBTYP

 +12       QUIT 

 +13      ;