Routine: AG

AG ; IHS/ASDS/EFG - INITIAL ROUTINE AND UTILITY SUB-ROUTINES ;

 ;;7.1;PATIENT REGISTRATION;**1,2,12**;AUG 25, 2005;Build 1

 ;IHS/OIT/NKD AG*7.1*12 REVISED VERSION/PATCH DISPLAY

 ; ****************************************************************

 S AG("VERDT")=""

 S AG("VERSION")=""

 S Y=""

 S (AGIEN,Y)=$O(^DIC(9.4,"C","AG",Y))

 I Y S AG("VERSION")=^DIC(9.4,Y,"VERSION")

 I AG("VERSION")]"" S Y=$O(^DIC(9.4,Y,22,"B",AG("VERSION"),""))

 I Y]"" D

 . S Y=$P(^DIC(9.4,AGIEN,22,Y,0),U,2)

 . D DD^%DT

 . S AG("VERDT")=Y

 I '$D(IOF) D

 . S IOP=ION

 . D ^%ZIS

 W $$S^AGVDF("IOF"),!?22

 F I=1:1:35 W "*"

 W !?22,"*",?56,"*"

 W !?22,"*      INDIAN HEALTH SERVICE      *"

 W !?22,"*   PATIENT REGISTRATION SYSTEM   *"

 ;IHS/OIT/NKD AG*7.1*12 - REVISED DISPLAY - START OLD CODE

 ;I AG("VERSION")]"" D

 ;. ;W !?22,"*     VERSION ",AG("VERSION"),", ",AG("VERDT"),?56,"*"

 ;. W !?22,"*   VERSION ",AG("VERSION") W ".",$$CURPATCH

 ;. W ", ",AG("VERDT"),?56,"*"

 ;IHS/OIT/NKD AG*7.1*12 - END OLD CODE - START NEW CODE

 . N AGTMP

 . S AGTMP=$$LAST^XPDUTL("AG","7.1") I +AGTMP>0 W !?22,"*   AG V7.1 P",+AGTMP,", ",$$FMTE^XLFDT($P(AGTMP,"^",2),"5D"),?56,"*"

 . S AGTMP=$$LAST^XPDUTL("AG","7.2") I +AGTMP>0 W !?22,"*   AGMPI V7.2 P",+AGTMP,", ",$$FMTE^XLFDT($P(AGTMP,"^",2),"5D"),?56,"*"

 ;IHS/OIT/NKD AG*7.1*12 - END NEW CODE

 W !?22,"*",?56,"*",!?22

 F I=1:1:35 W "*"

SITE ;EP - From options.

 I '$D(DUZ(2)) D SET^XBSITE G L4:'$D(DUZ(2))

 W !!?80-$L($P(^DIC(4,DUZ(2),0),U))\2,$P(^(0),U)

 W !!,$$CJ^XLFSTR("*** NOTE:  IF YOU EDIT A PATIENT AND SEE THEIR NAME IN REVERSE VIDEO ***",IOM)

 W !,$$CJ^XLFSTR("*** WITH '(RHI)' BLINKING NEXT TO IT, IT MEANS THEY HAVE RESTRICTED ***",IOM)

 W !,$$CJ^XLFSTR("*** HEALTH INFORMATION ***",IOM)

L4 ;

W !

 K AG,I,AG("VERDT"),AG("VERSION")

CURPATCH() ;EP - GET CURRENT PATCH LEVEL FOR HEADER

 N %,I,J

 S I=$O(^DIC(9.4,"B","IHS PATIENT REGISTRATION",0)) Q:'I 0

 S PENTRY=$O(^DIC(9.4,I,22,"B",AG("VERSION"),"")) Q:'PENTRY 0

 S PVER=$O(^DIC(9.4,I,22,PENTRY,"PAH","B"),-1) Q:'PVER 0

 S PVER=$P($G(^DIC(9.4,I,22,PENTRY,"PAH",PVER,0)),U)

 Q PVER

 ; ****************************************************************

READ ;EP - Standard READ sub-routine for Registration.

 K DIRUT  ;AG*7.1*2 ISSUE REPORTED DURING ALPHA TESTING

 K DFOUT,DTOUT,DUOUT,DQOUT,DLOUT R Y:DTIME I '$T W *7 R Y:5 G READ:Y="." I '$T S (DTOUT,Y)="" Q

 S:Y="/.," (DFOUT,Y)=""

 S:Y="" DLOUT=""

 S:Y="^" (DUOUT,Y)=""

 S:Y?1"?".E!(Y[U) (DQOUT,Y)=""

 ; ****************************************************************

RTRN ;EP

 S Y=1

 I $E(IOST)="C" D

 . S DIR(0)="E"

 . D ^DIR

 . K DIR

 ; ****************************************************************

NOW ;EP - Set AGTIME to time now.

 D NOW^%DTC

 S Y=%

 D DD^%DT

 S AGTIME=Y

 ; ****************************************************************

LINE ;EP - Standard writeline sub-routine.

W !

 F AG("LI")=1:1:78 W AG("LINE")

W !

 ; ****************************************************************

LINES ;EP  "Standard" lines of characters.

 S AG("-")=""

 S $P(AG("-"),"-",80)=""

 S AG("=")=""

 S $P(AG("="),"=",80)=""

 S AG("*")=""

 S $P(AG("*"),"*",80)=""

 ; ****************************************************************

CTR ;EP - Center X.

 S X=$J("",80-$L(X)\2)_X

 ; ****************************************************************

YN ;EP

 W !!,"Enter a ""Y"" for YES or an ""N"" for NO."

 ; ****************************************************************

KILL ;PEP - USED BY TPB TO CLEAN UP VARIABLES

 K ^UTILITY("DIQ1",$J)

 K %DT,A,AG,AGCHRT,AGI,AGLINE,AGOPT,AGPAT,AGSITE,AGUPDT

 K C,DFN,AG("DENT"),DFOUT,DIC,DIE,DLOUT,DTOUT,DQOUT,DUOUT,G,AGL,I,L

 K AGNEW,AGPCC,AGSCRN,AGTEMP,AG("TRBCODE"),X,XY,XYER,Y

 K AGAIN

 K AGSELECT

 ; ****************************************************************

VIDEO ;EP

 S XY=$G(^%ZIS(2,IOST(0),"XY")),XYER=$P($G(^(5)),"^",6)

 I XYER]"" S XYER="W "_XYER

 ; ****************************************************************

PTLK ;EP - Standard pt lookup using DIC.

 K DFN,RHIFLAG

 K DIC

 ;ENTER HERE IF YOU WISH TO KILL DIC YOURSELF

PTLKNKIL ;

 S DIC="^AUPNPAT("

 S DIC(0)="AEMQ"

 D ^DIC

 ;I Y'=-1 S DFN=+Y D CHKRHI^AG

 I Y'=-1 S (AGPATDFN,DFN)=+Y D CHKRHI^AG  ;IHS/SD/TPF AG*7.1*1 FIX PROBLEM WITH CURRENT PAT. IN EDIT SCREEN CHANGING WHEN PATIENT LOOKUP IS USED (DFN CHANGES)

 I $D(RHIFLAG)  D

 . I RHIFLAG="A" W !,$$S^AGVDF("RVN"),$$S^AGVDF("BLN"),"This patient has Restricted Health Information",$$S^AGVDF("BLF"),$$S^AGVDF("RVF")

 ;ADD ALERT IF PATIENT HAS 'DATE OF DEATH' POPULATED IN VA

 ;PATIENT FILE

 I $D(DFN) I $$CHKDEATH^AGEDERR(DFN) W !!?5,"**** ALERT: DATE OF DEATH ON FILE FOR THIS PATIENT!!" H 2

 ; ****************************************************************

HDR ;EP - Print menu header.

 K AGNEWINS,DIR

 D:'$D(AGOPT) ^AGVAR

 I $D(X) S X=$P(^DIC(19,$O(^DIC(19,"B",X,0)),0),U,2)

 S Y="AG"

 G SHDR

 ; ****************************************************************

PHDR ;EP - Print parent menu header.

 D:$D(AGOPT) KILL

 I ^XUTL("XQ",$J,"T")=1 Q

 I ^XUTL("XQ",$J,^XUTL("XQ",$J,"T")-1)=-1 Q

 S X=$P(^DIC(19,+^XUTL("XQ",$J,^XUTL("XQ",$J,"T")-1),0),U,2)

 S Y=$P(^DIC(19,+^XUTL("XQ",$J,^XUTL("XQ",$J,"T")-1),0),U)

 I Y="AGMASTER" D ^AG Q

SHDR ;EP - Screen header.

 I '$D(IOF) D    ; defensive for menu jumping

 . S IOP="HOME"

 . D ^%ZIS

 I $D(X) D CTR

 W $$S^AGVDF("IOF")

 W !!?30,$S($E(Y,1,2)="AG":"PATIENT REGISTRATION",1:"")

 W !!?40-($L($P(^DIC(4,DUZ(2),0),U))\2),$P(^(0),U)

 I $D(X) W !!,X,!

 Q:$D(AG("RPT"))

 W !!,$$CJ^XLFSTR("*** NOTE:  IF YOU EDIT A PATIENT AND SEE THEIR NAME IN REVERSE VIDEO ***",IOM)

 W !,$$CJ^XLFSTR("*** WITH '(RHI)' BLINKING NEXT TO IT, IT MEANS THEY HAVE RESTRICTED ***",IOM)

 W !,$$CJ^XLFSTR("*** HEALTH INFORMATION ***",IOM)

 ; ****************************************************************

CPI ;EP

 W !?21,"*** CONFIDENTIAL PATIENT INFORMATION ***"

 ; ****************************************************************

DFNTR ;EP - External Packages

 ;check transmission required fields for patient DFN

 D ^AGDATCK

 D ^AGBADATA

 K AG,AGOPT,AGQI,AGQT,AGTP

 ; ****************************************************************

T ;EP - DISPLAY TIME IN HH:MM (AM/PM) FORMAT

 D NOW^%DTC

 S AG("TIME")=$P(%,".",2)

 S AG("HOUR")=$E(AG("TIME"),1,2)

 S AG("MINUTE")=$E(AG("TIME"),3,4)

 S AG("AMPM")="AM"

 I AG("HOUR")>11 D

 .S AG("AMPM")="PM"

 .I AG("HOUR")>12 S AG("HOUR")=AG("HOUR")-12

 W $J(+AG("HOUR"),2),":",AG("MINUTE")," ",AG("AMPM")

 ; ****************************************************************

CHKNPP ;EP - CHECK PATIENT FOR NOTICE OF PRIVACY PRACTICES ENTRY

 K REC,NPPFLAG

 S REC=$O(^AUPNNPP("B",DFN,""),-1)

 Q:REC=""

 S NPPFLAG=""

CHKRHI ;EP - CHECK PATIENT FOR RESTRICTED HEALTH INFORMATION

 Q:'$D(DFN)

 S REC=0 S RHIFLAG=""

 F  S REC=$O(^AUPNRHI("B",DFN,REC)) Q:'REC  D

 . I $P($G(^AUPNRHI(REC,0)),U,3)="A" S RHIFLAG="A"

AG        ; IHS/ASDS/EFG - INITIAL ROUTINE AND UTILITY SUB-ROUTINES ;

 +1       ;;7.1;PATIENT REGISTRATION;**1,2,12**;AUG 25, 2005;Build 1

 +2       ;IHS/OIT/NKD AG*7.1*12 REVISED VERSION/PATCH DISPLAY

 +3       ;

 +4       ; ****************************************************************

 +5       ;

 +6        SET AG("VERDT")=""

 +7        SET AG("VERSION")=""

 +8        SET Y=""

 +9        SET (AGIEN,Y)=$ORDER(^DIC(9.4,"C","AG",Y))

 +10       IF Y

               SET AG("VERSION")=^DIC(9.4,Y,"VERSION")

 +11       IF AG("VERSION")]""

               SET Y=$ORDER(^DIC(9.4,Y,22,"B",AG("VERSION"),""))

 +12       IF Y]""

               Begin DoDot:1

 +13               SET Y=$PIECE(^DIC(9.4,AGIEN,22,Y,0),U,2)

 +14               DO DD^%DT

 +15               SET AG("VERDT")=Y

               End DoDot:1

 +16       IF '$DATA(IOF)

               Begin DoDot:1

 +17               SET IOP=ION

 +18               DO ^%ZIS

               End DoDot:1

 +19       WRITE $$S^AGVDF("IOF"),!?22

 +20       FOR I=1:1:35

               WRITE "*"

 +21       WRITE !?22,"*",?56,"*"

 +22       WRITE !?22,"*      INDIAN HEALTH SERVICE      *"

 +23       WRITE !?22,"*   PATIENT REGISTRATION SYSTEM   *"

 +24      ;IHS/OIT/NKD AG*7.1*12 - REVISED DISPLAY - START OLD CODE

 +25      ;I AG("VERSION")]"" D

 +26      ;. ;W !?22,"*     VERSION ",AG("VERSION"),", ",AG("VERDT"),?56,"*"

 +27      ;. W !?22,"*   VERSION ",AG("VERSION") W ".",$$CURPATCH

 +28      ;. W ", ",AG("VERDT"),?56,"*"

 +29      ;IHS/OIT/NKD AG*7.1*12 - END OLD CODE - START NEW CODE

 +30       Begin DoDot:1

 +31           NEW AGTMP

 +32           SET AGTMP=$$LAST^XPDUTL("AG","7.1")

               IF +AGTMP>0

                   WRITE !?22,"*   AG V7.1 P",+AGTMP,", ",$$FMTE^XLFDT($PIECE(AGTMP,"^",2),"5D"),?56,"*"

 +33           SET AGTMP=$$LAST^XPDUTL("AG","7.2")

               IF +AGTMP>0

                   WRITE !?22,"*   AGMPI V7.2 P",+AGTMP,", ",$$FMTE^XLFDT($PIECE(AGTMP,"^",2),"5D"),?56,"*"

           End DoDot:1

 +34      ;IHS/OIT/NKD AG*7.1*12 - END NEW CODE

 +35       WRITE !?22,"*",?56,"*",!?22

 +36       FOR I=1:1:35

               WRITE "*"

 +37      ;

SITE      ;EP - From options.

 +1        IF '$DATA(DUZ(2))

               DO SET^XBSITE

               IF '$DATA(DUZ(2))

                   GOTO L4

 +2        WRITE !!?80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))\2,$PIECE(^(0),U)

 +3        WRITE !!,$$CJ^XLFSTR("*** NOTE:  IF YOU EDIT A PATIENT AND SEE THEIR NAME IN REVERSE VIDEO ***",IOM)

 +4        WRITE !,$$CJ^XLFSTR("*** WITH '(RHI)' BLINKING NEXT TO IT, IT MEANS THEY HAVE RESTRICTED ***",IOM)

 +5        WRITE !,$$CJ^XLFSTR("*** HEALTH INFORMATION ***",IOM)

 +6       ;

L4        ;

 +1        WRITE !

 +2        KILL AG,I,AG("VERDT"),AG("VERSION")

 +3        QUIT

CURPATCH() ;EP - GET CURRENT PATCH LEVEL FOR HEADER

 +1        NEW %,I,J

 +2        SET I=$ORDER(^DIC(9.4,"B","IHS PATIENT REGISTRATION",0))

           IF 'I

               QUIT 0

 +3        SET PENTRY=$ORDER(^DIC(9.4,I,22,"B",AG("VERSION"),""))

           IF 'PENTRY

               QUIT 0

 +4        SET PVER=$ORDER(^DIC(9.4,I,22,PENTRY,"PAH","B"),-1)

           IF 'PVER

               QUIT 0

 +5        SET PVER=$PIECE($GET(^DIC(9.4,I,22,PENTRY,"PAH",PVER,0)),U)

 +6        QUIT PVER

 +7       ; ****************************************************************

READ      ;EP - Standard READ sub-routine for Registration.

 +1       ;AG*7.1*2 ISSUE REPORTED DURING ALPHA TESTING

           KILL DIRUT

 +2        KILL DFOUT,DTOUT,DUOUT,DQOUT,DLOUT

           READ Y:DTIME

           IF '$TEST

               WRITE *7

               READ Y:5

               IF Y="."

                   GOTO READ

               IF '$TEST

                   SET (DTOUT,Y)=""

                   QUIT

 +3        IF Y="/.,"

               SET (DFOUT,Y)=""

 +4        IF Y=""

               SET DLOUT=""

 +5        IF Y="^"

               SET (DUOUT,Y)=""

 +6        IF Y?1"?".E!(Y[U)

               SET (DQOUT,Y)=""

 +7        QUIT

 +8       ; ****************************************************************

RTRN      ;EP

 +1        SET Y=1

 +2        IF $EXTRACT(IOST)="C"

               Begin DoDot:1

 +3                SET DIR(0)="E"

 +4                DO ^DIR

 +5                KILL DIR

               End DoDot:1

 +6        QUIT

 +7       ; ****************************************************************

NOW       ;EP - Set AGTIME to time now.

 +1        DO NOW^%DTC

 +2        SET Y=%

 +3        DO DD^%DT

 +4        SET AGTIME=Y

 +5        QUIT

 +6       ; ****************************************************************

LINE      ;EP - Standard writeline sub-routine.

 +1        WRITE !

 +2        FOR AG("LI")=1:1:78

               WRITE AG("LINE")

 +3        WRITE !

 +4        QUIT

 +5       ; ****************************************************************

LINES     ;EP  "Standard" lines of characters.

 +1        SET AG("-")=""

 +2        SET $PIECE(AG("-"),"-",80)=""

 +3        SET AG("=")=""

 +4        SET $PIECE(AG("="),"=",80)=""

 +5        SET AG("*")=""

 +6        SET $PIECE(AG("*"),"*",80)=""

 +7        QUIT

 +8       ; ****************************************************************

CTR       ;EP - Center X.

 +1        SET X=$JUSTIFY("",80-$LENGTH(X)\2)_X

 +2        QUIT

 +3       ; ****************************************************************

YN        ;EP

 +1        WRITE !!,"Enter a ""Y"" for YES or an ""N"" for NO."

 +2        QUIT

 +3       ; ****************************************************************

KILL      ;PEP - USED BY TPB TO CLEAN UP VARIABLES

 +1        KILL ^UTILITY("DIQ1",$JOB)

 +2        KILL %DT,A,AG,AGCHRT,AGI,AGLINE,AGOPT,AGPAT,AGSITE,AGUPDT

 +3        KILL C,DFN,AG("DENT"),DFOUT,DIC,DIE,DLOUT,DTOUT,DQOUT,DUOUT,G,AGL,I,L

 +4        KILL AGNEW,AGPCC,AGSCRN,AGTEMP,AG("TRBCODE"),X,XY,XYER,Y

 +5        KILL AGAIN

 +6        KILL AGSELECT

 +7        QUIT

 +8       ; ****************************************************************

VIDEO     ;EP

 +1        SET XY=$GET(^%ZIS(2,IOST(0),"XY"))

           SET XYER=$PIECE($GET(^(5)),"^",6)

 +2        IF XYER]""

               SET XYER="W "_XYER

 +3        QUIT

 +4       ; ****************************************************************

PTLK      ;EP - Standard pt lookup using DIC.

 +1        KILL DFN,RHIFLAG

 +2        KILL DIC

 +3       ;ENTER HERE IF YOU WISH TO KILL DIC YOURSELF

PTLKNKIL  ;

 +1        SET DIC="^AUPNPAT("

 +2        SET DIC(0)="AEMQ"

 +3        DO ^DIC

 +4       ;I Y'=-1 S DFN=+Y D CHKRHI^AG

 +5       ;IHS/SD/TPF AG*7.1*1 FIX PROBLEM WITH CURRENT PAT. IN EDIT SCREEN CHANGING WHEN PATIENT LOOKUP IS USED (DFN CHANGES)

           IF Y'=-1

               SET (AGPATDFN,DFN)=+Y

               DO CHKRHI^AG

 +6        IF $DATA(RHIFLAG)

               Begin DoDot:1

 +7                IF RHIFLAG="A"

                       WRITE !,$$S^AGVDF("RVN"),$$S^AGVDF("BLN"),"This patient has Restricted Health Information",$$S^AGVDF("BLF"),$$S^AGVDF("RVF")

               End DoDot:1

 +8       ;ADD ALERT IF PATIENT HAS 'DATE OF DEATH' POPULATED IN VA

 +9       ;PATIENT FILE

 +10       IF $DATA(DFN)

               IF $$CHKDEATH^AGEDERR(DFN)

                   WRITE !!?5,"**** ALERT: DATE OF DEATH ON FILE FOR THIS PATIENT!!"

                   HANG 2

 +11       QUIT

 +12      ; ****************************************************************

HDR       ;EP - Print menu header.

 +1        KILL AGNEWINS,DIR

 +2        IF '$DATA(AGOPT)

               DO ^AGVAR

 +3        IF $DATA(X)

               SET X=$PIECE(^DIC(19,$ORDER(^DIC(19,"B",X,0)),0),U,2)

 +4        SET Y="AG"

 +5        GOTO SHDR

 +6       ; ****************************************************************

PHDR      ;EP - Print parent menu header.

 +1        IF $DATA(AGOPT)

               DO KILL

 +2        IF ^XUTL("XQ",$JOB,"T")=1

               QUIT

 +3        IF ^XUTL("XQ",$JOB,^XUTL("XQ",$JOB,"T")-1)=-1

               QUIT

 +4        SET X=$PIECE(^DIC(19,+^XUTL("XQ",$JOB,^XUTL("XQ",$JOB,"T")-1),0),U,2)

 +5        SET Y=$PIECE(^DIC(19,+^XUTL("XQ",$JOB,^XUTL("XQ",$JOB,"T")-1),0),U)

 +6        IF Y="AGMASTER"

               DO ^AG

               QUIT

 +7       ;

SHDR      ;EP - Screen header.

 +1       ; defensive for menu jumping

           IF '$DATA(IOF)

               Begin DoDot:1

 +2                SET IOP="HOME"

 +3                DO ^%ZIS

               End DoDot:1

 +4        IF $DATA(X)

               DO CTR

 +5        WRITE $$S^AGVDF("IOF")

 +6        WRITE !!?30,$SELECT($EXTRACT(Y,1,2)="AG":"PATIENT REGISTRATION",1:"")

 +7        WRITE !!?40-($LENGTH($PIECE(^DIC(4,DUZ(2),0),U))\2),$PIECE(^(0),U)

 +8        IF $DATA(X)

               WRITE !!,X,!

 +9        IF $DATA(AG("RPT"))

               QUIT

 +10       WRITE !!,$$CJ^XLFSTR("*** NOTE:  IF YOU EDIT A PATIENT AND SEE THEIR NAME IN REVERSE VIDEO ***",IOM)

 +11       WRITE !,$$CJ^XLFSTR("*** WITH '(RHI)' BLINKING NEXT TO IT, IT MEANS THEY HAVE RESTRICTED ***",IOM)

 +12       WRITE !,$$CJ^XLFSTR("*** HEALTH INFORMATION ***",IOM)

 +13       QUIT

 +14      ; ****************************************************************

CPI       ;EP

 +1        WRITE !?21,"*** CONFIDENTIAL PATIENT INFORMATION ***"

 +2        QUIT

 +3       ; ****************************************************************

DFNTR     ;EP - External Packages

 +1       ;check transmission required fields for patient DFN

 +2        DO ^AGDATCK

 +3        DO ^AGBADATA

 +4        KILL AG,AGOPT,AGQI,AGQT,AGTP

 +5        QUIT

 +6       ; ****************************************************************

T         ;EP - DISPLAY TIME IN HH:MM (AM/PM) FORMAT

 +1        DO NOW^%DTC

 +2        SET AG("TIME")=$PIECE(%,".",2)

 +3        SET AG("HOUR")=$EXTRACT(AG("TIME"),1,2)

 +4        SET AG("MINUTE")=$EXTRACT(AG("TIME"),3,4)

 +5        SET AG("AMPM")="AM"

 +6        IF AG("HOUR")>11

               Begin DoDot:1

 +7                SET AG("AMPM")="PM"

 +8                IF AG("HOUR")>12

                       SET AG("HOUR")=AG("HOUR")-12

               End DoDot:1

 +9        WRITE $JUSTIFY(+AG("HOUR"),2),":",AG("MINUTE")," ",AG("AMPM")

 +10       QUIT

 +11      ; ****************************************************************

CHKNPP    ;EP - CHECK PATIENT FOR NOTICE OF PRIVACY PRACTICES ENTRY

 +1        KILL REC,NPPFLAG

 +2        SET REC=$ORDER(^AUPNNPP("B",DFN,""),-1)

 +3        IF REC=""

               QUIT

 +4        SET NPPFLAG=""

 +5        QUIT

CHKRHI    ;EP - CHECK PATIENT FOR RESTRICTED HEALTH INFORMATION

 +1        IF '$DATA(DFN)

               QUIT

 +2        SET REC=0

           SET RHIFLAG=""

 +3        FOR

               SET REC=$ORDER(^AUPNRHI("B",DFN,REC))

               IF 'REC

                   QUIT

               Begin DoDot:1

 +4                IF $PIECE($GET(^AUPNRHI(REC,0)),U,3)="A"

                       SET RHIFLAG="A"

               End DoDot:1

 +5        QUIT

AG.m