MCARGPA.m

MCARGPA ;WISC/MLH-PRINT ALLERGY INFO ON 'MCAROGH' PRINT TEMPLATE ;7/12/00  11:46

 ;;2.3;Medicine;**28**;09/13/1996

 X "N DFN K GMRAL S DFN=$P($G(^MCAR(699,MCARGDA,0)),U,2) D ^GMRADPT"

 I $G(GMRAL)=1 D

 .  X "N MCAR,MCAR0 F MCAR=0:0 S MCAR=$O(GMRAL(MCAR)) Q:MCAR'>0!'DN  D N:$X>5 Q:'DN  W ?5,$P(GMRAL(MCAR),U,2) F MCAR1=0:0 S MCAR1=$O(^GMR(120.8,MCAR,10,MCAR1)) Q:MCAR1'>0  D:$X>35 N Q:'DN  W ?35,$$RXN(MCAR,MCAR1)"

 .  K GMRAL

 .  QUIT

 E  W ?35,$S($G(GMRAL)=0:"NKA",1:""),!

 Q

 ;

RXN(X,Y) ; FUNCTION WHOSE VALUE IS PRINTABLE RXN IN ENTRY ^GMR(120.8,X,10,Y,0)

 N MCAR,MCAR1 S MCAR=$G(^GMR(120.8,X,10,Y,0)),MCAR1=$P(MCAR,U)

 Q $S('MCAR1:"",MCAR1'=$O(^GMRD(120.83,"B","OTHER REACTION",0)):$P($G(^GMRD(120.83,MCAR1,0)),U),1:$P(MCAR,U,2))

 ;

N W !

T W:$X ! I '$D(DIOT(2)),DN,$D(IOSL),$S('$D(DIWF):1,$P(DIWF,"B",2):$P(DIWF,"B",2),1:1)+$Y'<IOSL,$D(^UTILITY($J,1))#2,^(1)?1U1P1E.E X ^(1)

 Q

MCARGPA   ;WISC/MLH-PRINT ALLERGY INFO ON 'MCAROGH' PRINT TEMPLATE ;7/12/00  11:46

 +1       ;;2.3;Medicine;**28**;09/13/1996

 +2        XECUTE "N DFN K GMRAL S DFN=$P($G(^MCAR(699,MCARGDA,0)),U,2) D ^GMRADPT"

 +3        IF $GET(GMRAL)=1

               Begin DoDot:1

 +4                XECUTE "N MCAR,MCAR0 F MCAR=0:0 S MCAR=$O(GMRAL(MCAR)) Q:MCAR'>0!'DN  D N:$X>5 Q:'DN  W ?5,$P(GMRAL(MCAR),U,2) F MCAR1=0:0 S MCAR1=$O(^GMR(120.8,MCAR,10,MCAR1)) Q:MCAR1'>0  D:$X>35 N Q:'DN  W ?35,$$RXN(MCAR,MCAR1)"

 +5                KILL GMRAL

 +6                QUIT 

               End DoDot:1

 +7       IF '$TEST

               WRITE ?35,$SELECT($GET(GMRAL)=0:"NKA",1:""),!

 +8        QUIT 

 +9       ;

RXN(X,Y)  ; FUNCTION WHOSE VALUE IS PRINTABLE RXN IN ENTRY ^GMR(120.8,X,10,Y,0)

 +1        NEW MCAR,MCAR1

           SET MCAR=$GET(^GMR(120.8,X,10,Y,0))

           SET MCAR1=$PIECE(MCAR,U)

 +2        QUIT $SELECT('MCAR1:"",MCAR1'=$ORDER(^GMRD(120.83,"B","OTHER REACTION",0)):$PIECE($GET(^GMRD(120.83,MCAR1,0)),U),1:$PIECE(MCAR,U,2))

 +3       ;

N          WRITE !

T          IF $X

               WRITE !

           IF '$DATA(DIOT(2))

               IF DN

                   IF $DATA(IOSL)

                       IF $SELECT('$DATA(DIWF):1,$PIECE(DIWF,"B",2):$PIECE(DIWF,"B",2),1:1)+$Y'<IOSL

                           IF $DATA(^UTILITY($JOB,1))#2

                               IF ^(1)?1U1P1E.E

                                   XECUTE ^(1)

 +1        QUIT