APCDEREF.m

APCDEREF ; IHS/CMI/LAB - prompt for refusal value ; 23 May 2013  10:50 AM

 ;;2.0;IHS PCC SUITE;**11,17**;MAY 14, 2009;Build 18

 ;

IN ;EP

 ;lookup refusal type and create entry

 I $G(APCDTREF)="" W !,"Refusal type missing.....!" Q

 S APCDT02=$G(APCDPAT)

 I APCDT02="" S APCDT02=$G(DFN)

 I 'APCDT02 W !!,"Patient missing..." Q

 D EN^XBNEW("IN1^APCDEREF","APCDTREF;APCDT02")

 Q

IN1 ;EP - called from xbnew to create a refusal entry

 S DIC="^AUTTREFT(",DIC(0)="AEMQ",DIC("A")="PATIENT REFUSALS FOR SERVICE/NMI SERVICE TYPE: "

 D ^DIC

 I Y=-1 Q

 I $P(^AUTTREFT(+Y,0),U)="SNOMED" W !!,"That type of refusal cannot be entered through PCC Data Entry.",! Q

 S APCDT01=+Y

VALUE ;EP - called from input template

 S APCDTF=$P(^AUTTREFT(APCDT01,0),U,2)

 I 'APCDTF W !!,"table file missing..." Q

 K X,DUOUT,DIRUT

 I $P(^AUTTREFT(APCDT01,0),U)="RXNORM" D RX Q

 K DIC S DIC("B")=$S($D(APCDTOLD):APCDTOLD,1:""),DIC("A")="  Enter the "_$P(^DIC(APCDTF,0),U)_" value: ",DIC=APCDTF,DIC(0)="AEMQ"

 ;I APCDTF=80.1 S DIC("S")="D ICDOPCHK^AUPNSICD"

 D ^DIC K DIC

 I $P(Y,U)=-1 W !!,"Invalid entry.  Try again." G VALUE

 S APCDTFI=+Y

 I APCDTF=80.1 S APCDTID=$P($$ICDOP^ICDEX(APCDTFI,,,"I"),U,5) I 1

 E  S APCDTID=$$VAL^XBDIQ1(APCDTF,APCDTFI,$P(^AUTTREFT(APCDT01,0),U,3))

 D CENTRY  ;create the entry and edit

EOJ ;

 K Y

 Q

 ;

CENTRY ;

 I $G(APCDTDA) G CENTRYE

 S X=APCDT01,DIC="^AUPNPREF(",DIC(0)="L",DIC("DR")=".02////"_APCDT02 K DD,DO,D0 D FILE^DICN K DIC

 I Y=-1 W !,"ERROR CREATING ENTRY....TRY AGAIN..." Q

 S APCDTDA=+Y

CENTRYE ;now edit it

 ;FIRST WIPE OUT FIELDS

 S DA=APCDTDA,DIE="^AUPNPREF(",DR="1301///@;1302///@;.04///@;.05///@;.07///@" D ^DIE K DIE,DA,DR

 S DIE("NO^")="",DA=APCDTDA,DIE="^AUPNPREF(",DR="[APCD REF ADD]" D ^DIE K DIE,DA,DR

 Q

MOD(APCDP) ;EP

 ;select entry for modify and pass to template in APCDLOOK

 S APCDTIEN=""

 D EN^XBNEW("MOD1^APCDEREF","APCDP;APCDTIEN")

 S APCDLOOK=$G(APCDTIEN)

 I 'APCDLOOK W !!,"No entry selected" S APCDTERR=1 Q

 Q

MOD1 ;EP called from xbnew

 W !?2,"0)  None"

 NEW APCDX,APCDC,APCDD K APCDD S (APCDX,APCDC)=0

 F  S APCDX=$O(^AUPNPREF("AC",APCDP,APCDX)) Q:APCDX'=+APCDX  S APCDC=APCDC+1,APCDD(APCDC)=APCDX W !?2,APCDC,")",?6,$E($$VAL^XBDIQ1(9000022,APCDX,.01),1,15),?22,$$VAL^XBDIQ1(9000022,APCDX,.04),?54,$$VAL^XBDIQ1(9000022,APCDX,.03)

 S DIR(0)="N^0:99999:",DIR("A")="Which one do you wish to modify or delete",DIR("B")="0" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) Q

 I 'Y Q

 S APCDTIEN=$G(APCDD(Y))

 Q

MOD2 ;EP called from input template

 D EN^XBNEW("VALUE^APCDEREF","APCDTMOD;APCDTDA;APCDT01;APCDTREF;APCDTOLD")

 Q

EN(PATIENT,VFIEN) ;EP - called from APCD EL (ADD/MOD) templates

 I '$G(PATIENT) Q

 I '$G(VFIEN) Q

 I '$D(^AUPNVELD(VFIEN)) Q

 D EN^XBNEW("EN1^APCDEREF","VFIEN;PATIENT")

 Q

EN1 ;EP - called from XBNEW to update elder care status

 I '$D(^AUPNELDC("B",PATIENT)) G ADDEC

EDITEC ;

 S DA=PATIENT,DIE="^AUPNELDC("

 NEW VF

 S VF=^AUPNVELD(VFIEN,0)

 NEW D

 S D=$P($P(^AUPNVSIT($P(^AUPNVELD(VFIEN,0),U,3),0),U),".")

 I $P(^AUPNELDC(PATIENT,0),U,3)]D Q  ;later entry already updated

 S DR=".03////"_D_";.04////"_$P(VF,U,4)_";.05////"_$P(VF,U,5)_";.06////"_$P(VF,U,6)_";.07////"_$P(VF,U,7)_";.08////"_$P(VF,U,8)_";.09////"_$P(VF,U,9)_";.11////"_$P(VF,U,11)_";.12////"_$P(VF,U,12)_";.13////"_$P(VF,U,13)

 S DR=DR_";.14////"_$P(VF,U,14)_";.15////"_$P(VF,U,15)_";.16////"_$P(VF,U,16)_";.17////"_$P(VF,U,17)_";.18////"_$P(VF,U,18)

 D ^DIE

XIT ;

 K DIADD,DLAYGO,DD,DO,D0,DIC

 K DA,DIE,DIU,DIV,DIW,DR

 Q

ADDEC ;

 S DLAYGO=9000023,DIC="^AUPNELDC(",DIC(0)="L"

 S X="`"_PATIENT

 D ^DIC K DIC

 I Y=-1 W !,"ERROR ADDING ELDER CARE STATUS ENTRY" D XIT Q

 D EDITEC

 Q

RX ;

 ;prompt for rxnorm code or text

 ;call bsts srch if not all numbers

 K DIR

 S (APCDTID,APCDTF,APCDTFI,APCDTDID)=""

 S APCDTF=$P(^AUTTREFT(APCDT01,0),U,2)

 W !

 S DIR(0)="F^1:60",DIR("A")="Enter the RXNORM code or drug ingredient (or '^' to exit)" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) Q

 S APCDRXN=Y

 I APCDRXN?.N D  I APCDTID="" G RX

 .S APCDRXN1=$$CONC^BSTSAPI(APCDRXN_"^1552^^1")

 .Q:$P(APCDRXN1,U)=""  ;W !!,APCDRXN1 H 2

 .W !!,$P(APCDRXN1,U,1)," ",$P(APCDRXN1,U,2)

 .S (APCDTFI,APCDTCON)=APCDRXN

 .S APCDTID=$P(APCDRXN1,U,2)

 .S APCDTDID=$P(APCDRXN1,U,1)

 .D CENTRY

 .Q

 I APCDRXN'?.N D  I APCDTID="" G RX

 .NEW OUT,VARS,IN,APCDC

 .S OUT="VARS",IN=APCDRXN,$P(IN,U,2)="F",$P(IN,U,3)=1552 I $$SUBE("RXNO SRCH Drug Ingredients All") S $P(IN,U,4)="RXNO SRCH Drug Ingredients All"

 .S APCDC=$$SEARCH^BSTSAPI(OUT,IN)

 .I +APCDC<1 W !!,?9,"No entries found in the IHS STANDARD RXNORM TERMINOLOGY database."

 .I +APCDC>0&(APCDC'=9999999) D GETANS

 .I '$G(APCDY) Q

 .S (APCDTFI,APCDTCON)=VARS(APCDY,"CON")

 .S APCDTID=$G(VARS(APCDY,"FSN","TRM"))

 .S APCDTDID=$G(VARS(APCDY,"FSN","DSC"))

 .D CENTRY

 .Q

 Q

GETANS ;EP - DISPLAY RXNORM ARRAY

 NEW APCDX,APCDZ,APCDQ,APCDCNT,APCDTOT,Z,MF

 S MF=0

 S Z=0 F  S Z=$O(VARS(Z)) Q:Z'=+Z  S MF=MF+1

 W !!?5,MF," matches found.",!

 S APCDX=0,APCDY="",APCDQ=0,APCDCNT=0,APCDTOT=0

 F  S APCDX=$O(VARS(APCDX)) Q:APCDX'=+APCDX!(APCDY]"")  D

DISP .;display code

 .W !?3,APCDX,")"

 .S APCDZ=$G(VARS(APCDX,"FSN","TRM"))

 .I APCDX="" S APCDX="MISSING FULLY SPECIFIED TERM"

 .K ^UTILITY($J)

 .S X=APCDZ,DIWL=0,DIWR=70 D ^DIWP

 .S Z=0 F  S Z=$O(^UTILITY($J,"W",0,Z)) Q:Z'=+Z  W:Z>1 ! W ?9,^UTILITY($J,"W",0,Z,0)

 .K ^UTILITY($J)

 .S APCDCNT=APCDCNT+1,APCDTOT=APCDTOT+1

 .I MF=1 S APCDCNT=1,APCDTOT=1 D READ S:APCDY="" APCDY="^" Q

 .I MF>4,APCDCNT=5!(MF=APCDTOT) D READ S APCDCNT=0 Q

 .I MF<5,MF=APCDX D READ S APCDNT=0 Q:APCDY]""

 .Q

 Q

READ ;

 K DIR,DIRUT

 S APCDY=""

 W !

 ;W !,"Type ""^"" to STOP, press ENTER to continue the list or SELECT 1-"_APCDTOT

 S DIR("B")=$S(MF=1:1,1:""),DIR(0)="NO^1:"_APCDTOT_":0"

 S DIR("A")="Type ""^"" to STOP or SELECT 1-"_APCDTOT

 KILL DA D ^DIR W !

 I $D(DIRUT) S APCDY="^"

 I Y="" S APCDY="" Q

 S APCDY=+Y

 Q	

SUBE(X) ;EP - does this subset exist?

 NEW LST,Y,G

 S G=""

 S Y=$$SUBSET^BSTSAPI("LST",1552)

 S Y=0 F  S Y=$O(LST(Y)) Q:Y'=+Y!(G)  D

 .I $P(LST(Y),U,1)=X S G=1

 .Q

 Q G

APCDEREF  ; IHS/CMI/LAB - prompt for refusal value ; 23 May 2013  10:50 AM

 +1       ;;2.0;IHS PCC SUITE;**11,17**;MAY 14, 2009;Build 18

 +2       ;

IN        ;EP

 +1       ;lookup refusal type and create entry

 +2        IF $GET(APCDTREF)=""

               WRITE !,"Refusal type missing.....!"

               QUIT 

 +3        SET APCDT02=$GET(APCDPAT)

 +4        IF APCDT02=""

               SET APCDT02=$GET(DFN)

 +5        IF 'APCDT02

               WRITE !!,"Patient missing..."

               QUIT 

 +6        DO EN^XBNEW("IN1^APCDEREF","APCDTREF;APCDT02")

 +7        QUIT 

IN1       ;EP - called from xbnew to create a refusal entry

 +1        SET DIC="^AUTTREFT("

           SET DIC(0)="AEMQ"

           SET DIC("A")="PATIENT REFUSALS FOR SERVICE/NMI SERVICE TYPE: "

 +2        DO ^DIC

 +3        IF Y=-1

               QUIT 

 +4        IF $PIECE(^AUTTREFT(+Y,0),U)="SNOMED"

               WRITE !!,"That type of refusal cannot be entered through PCC Data Entry.",!

               QUIT 

 +5        SET APCDT01=+Y

VALUE     ;EP - called from input template

 +1        SET APCDTF=$PIECE(^AUTTREFT(APCDT01,0),U,2)

 +2        IF 'APCDTF

               WRITE !!,"table file missing..."

               QUIT 

 +3        KILL X,DUOUT,DIRUT

 +4        IF $PIECE(^AUTTREFT(APCDT01,0),U)="RXNORM"

               DO RX

               QUIT 

 +5        KILL DIC

           SET DIC("B")=$SELECT($DATA(APCDTOLD):APCDTOLD,1:"")

           SET DIC("A")="  Enter the "_$PIECE(^DIC(APCDTF,0),U)_" value: "

           SET DIC=APCDTF

           SET DIC(0)="AEMQ"

 +6       ;I APCDTF=80.1 S DIC("S")="D ICDOPCHK^AUPNSICD"

 +7        DO ^DIC

           KILL DIC

 +8        IF $PIECE(Y,U)=-1

               WRITE !!,"Invalid entry.  Try again."

               GOTO VALUE

 +9        SET APCDTFI=+Y

 +10       IF APCDTF=80.1

               SET APCDTID=$PIECE($$ICDOP^ICDEX(APCDTFI,,,"I"),U,5)

               IF 1

 +11      IF '$TEST

               SET APCDTID=$$VAL^XBDIQ1(APCDTF,APCDTFI,$PIECE(^AUTTREFT(APCDT01,0),U,3))

 +12      ;create the entry and edit

           DO CENTRY

EOJ       ;

 +1        KILL Y

 +2        QUIT 

 +3       ;

CENTRY    ;

 +1        IF $GET(APCDTDA)

               GOTO CENTRYE

 +2        SET X=APCDT01

           SET DIC="^AUPNPREF("

           SET DIC(0)="L"

           SET DIC("DR")=".02////"_APCDT02

           KILL DD,DO,D0

           DO FILE^DICN

           KILL DIC

 +3        IF Y=-1

               WRITE !,"ERROR CREATING ENTRY....TRY AGAIN..."

               QUIT 

 +4        SET APCDTDA=+Y

CENTRYE   ;now edit it

 +1       ;FIRST WIPE OUT FIELDS

 +2        SET DA=APCDTDA

           SET DIE="^AUPNPREF("

           SET DR="1301///@;1302///@;.04///@;.05///@;.07///@"

           DO ^DIE

           KILL DIE,DA,DR

 +3        SET DIE("NO^")=""

           SET DA=APCDTDA

           SET DIE="^AUPNPREF("

           SET DR="[APCD REF ADD]"

           DO ^DIE

           KILL DIE,DA,DR

 +4        QUIT 

MOD(APCDP) ;EP

 +1       ;select entry for modify and pass to template in APCDLOOK

 +2        SET APCDTIEN=""

 +3        DO EN^XBNEW("MOD1^APCDEREF","APCDP;APCDTIEN")

 +4        SET APCDLOOK=$GET(APCDTIEN)

 +5        IF 'APCDLOOK

               WRITE !!,"No entry selected"

               SET APCDTERR=1

               QUIT 

 +6        QUIT 

MOD1      ;EP called from xbnew

 +1        WRITE !?2,"0)  None"

 +2        NEW APCDX,APCDC,APCDD

           KILL APCDD

           SET (APCDX,APCDC)=0

 +3        FOR 

               SET APCDX=$ORDER(^AUPNPREF("AC",APCDP,APCDX))

               IF APCDX'=+APCDX

                   QUIT 

               SET APCDC=APCDC+1

               SET APCDD(APCDC)=APCDX

               WRITE !?2,APCDC,")",?6,$EXTRACT($$VAL^XBDIQ1(9000022,APCDX,.01),1,15),?22,$$VAL^XBDIQ1(9000022,APCDX,.04),?54,$$VAL^XBDIQ1(9000022,APCDX,.03)

 +4        SET DIR(0)="N^0:99999:"

           SET DIR("A")="Which one do you wish to modify or delete"

           SET DIR("B")="0"

           KILL DA

           DO ^DIR

           KILL DIR

 +5        IF $DATA(DIRUT)

               QUIT 

 +6        IF 'Y

               QUIT 

 +7        SET APCDTIEN=$GET(APCDD(Y))

 +8        QUIT 

MOD2      ;EP called from input template

 +1        DO EN^XBNEW("VALUE^APCDEREF","APCDTMOD;APCDTDA;APCDT01;APCDTREF;APCDTOLD")

 +2        QUIT 

EN(PATIENT,VFIEN) ;EP - called from APCD EL (ADD/MOD) templates

 +1        IF '$GET(PATIENT)

               QUIT 

 +2        IF '$GET(VFIEN)

               QUIT 

 +3        IF '$DATA(^AUPNVELD(VFIEN))

               QUIT 

 +4        DO EN^XBNEW("EN1^APCDEREF","VFIEN;PATIENT")

 +5        QUIT 

EN1       ;EP - called from XBNEW to update elder care status

 +1        IF '$DATA(^AUPNELDC("B",PATIENT))

               GOTO ADDEC

EDITEC    ;

 +1        SET DA=PATIENT

           SET DIE="^AUPNELDC("

 +2        NEW VF

 +3        SET VF=^AUPNVELD(VFIEN,0)

 +4        NEW D

 +5        SET D=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVELD(VFIEN,0),U,3),0),U),".")

 +6       ;later entry already updated

           IF $PIECE(^AUPNELDC(PATIENT,0),U,3)]D

               QUIT 

 +7       SET DR=".03////"_D_";.04////"_$PIECE(VF,U,4)_";.05////"_$PIECE(VF,U,5)_";.06////"_$PIECE(VF,U,6)_";.07////"_$PIECE(VF,U,7)_";.08////"_$PIECE(VF,U,8)_";.09////"_$PIECE(VF,U,9)_";.11////"_$PIECE(VF,U,11)_";.12////"_$PIECE(VF,U,12)_";.13////"_...

           ... $PIECE(VF,U,13)

 +8        SET DR=DR_";.14////"_$PIECE(VF,U,14)_";.15////"_$PIECE(VF,U,15)_";.16////"_$PIECE(VF,U,16)_";.17////"_$PIECE(VF,U,17)_";.18////"_$PIECE(VF,U,18)

 +9        DO ^DIE

XIT       ;

 +1        KILL DIADD,DLAYGO,DD,DO,D0,DIC

 +2        KILL DA,DIE,DIU,DIV,DIW,DR

 +3        QUIT 

ADDEC     ;

 +1        SET DLAYGO=9000023

           SET DIC="^AUPNELDC("

           SET DIC(0)="L"

 +2        SET X="`"_PATIENT

 +3        DO ^DIC

           KILL DIC

 +4        IF Y=-1

               WRITE !,"ERROR ADDING ELDER CARE STATUS ENTRY"

               DO XIT

               QUIT 

 +5        DO EDITEC

 +6        QUIT 

RX        ;

 +1       ;prompt for rxnorm code or text

 +2       ;call bsts srch if not all numbers

 +3        KILL DIR

 +4        SET (APCDTID,APCDTF,APCDTFI,APCDTDID)=""

 +5        SET APCDTF=$PIECE(^AUTTREFT(APCDT01,0),U,2)

 +6        WRITE !

 +7        SET DIR(0)="F^1:60"

           SET DIR("A")="Enter the RXNORM code or drug ingredient (or '^' to exit)"

           KILL DA

           DO ^DIR

           KILL DIR

 +8        IF $DATA(DIRUT)

               QUIT 

 +9        SET APCDRXN=Y

 +10       IF APCDRXN?.N

               Begin DoDot:1

 +11               SET APCDRXN1=$$CONC^BSTSAPI(APCDRXN_"^1552^^1")

 +12      ;W !!,APCDRXN1 H 2

                   IF $PIECE(APCDRXN1,U)=""

                       QUIT 

 +13               WRITE !!,$PIECE(APCDRXN1,U,1)," ",$PIECE(APCDRXN1,U,2)

 +14               SET (APCDTFI,APCDTCON)=APCDRXN

 +15               SET APCDTID=$PIECE(APCDRXN1,U,2)

 +16               SET APCDTDID=$PIECE(APCDRXN1,U,1)

 +17               DO CENTRY

 +18               QUIT 

               End DoDot:1

               IF APCDTID=""

                   GOTO RX

 +19       IF APCDRXN'?.N

               Begin DoDot:1

 +20               NEW OUT,VARS,IN,APCDC

 +21               SET OUT="VARS"

                   SET IN=APCDRXN

                   SET $PIECE(IN,U,2)="F"

                   SET $PIECE(IN,U,3)=1552

                   IF $$SUBE("RXNO SRCH Drug Ingredients All")

                       SET $PIECE(IN,U,4)="RXNO SRCH Drug Ingredients All"

 +22               SET APCDC=$$SEARCH^BSTSAPI(OUT,IN)

 +23               IF +APCDC<1

                       WRITE !!,?9,"No entries found in the IHS STANDARD RXNORM TERMINOLOGY database."

 +24               IF +APCDC>0&(APCDC'=9999999)

                       DO GETANS

 +25               IF '$GET(APCDY)

                       QUIT 

 +26               SET (APCDTFI,APCDTCON)=VARS(APCDY,"CON")

 +27               SET APCDTID=$GET(VARS(APCDY,"FSN","TRM"))

 +28               SET APCDTDID=$GET(VARS(APCDY,"FSN","DSC"))

 +29               DO CENTRY

 +30               QUIT 

               End DoDot:1

               IF APCDTID=""

                   GOTO RX

 +31       QUIT 

GETANS    ;EP - DISPLAY RXNORM ARRAY

 +1        NEW APCDX,APCDZ,APCDQ,APCDCNT,APCDTOT,Z,MF

 +2        SET MF=0

 +3        SET Z=0

           FOR 

               SET Z=$ORDER(VARS(Z))

               IF Z'=+Z

                   QUIT 

               SET MF=MF+1

 +4        WRITE !!?5,MF," matches found.",!

 +5        SET APCDX=0

           SET APCDY=""

           SET APCDQ=0

           SET APCDCNT=0

           SET APCDTOT=0

 +6        FOR 

               SET APCDX=$ORDER(VARS(APCDX))

               IF APCDX'=+APCDX!(APCDY]"")

                   QUIT 

               Begin DoDot:1

DISP      ;display code

 +1                WRITE !?3,APCDX,")"

 +2                SET APCDZ=$GET(VARS(APCDX,"FSN","TRM"))

 +3                IF APCDX=""

                       SET APCDX="MISSING FULLY SPECIFIED TERM"

 +4                KILL ^UTILITY($JOB)

 +5                SET X=APCDZ

                   SET DIWL=0

                   SET DIWR=70

                   DO ^DIWP

 +6                SET Z=0

                   FOR 

                       SET Z=$ORDER(^UTILITY($JOB,"W",0,Z))

                       IF Z'=+Z

                           QUIT 

                       IF Z>1

                           WRITE !

                       WRITE ?9,^UTILITY($JOB,"W",0,Z,0)

 +7                KILL ^UTILITY($JOB)

 +8                SET APCDCNT=APCDCNT+1

                   SET APCDTOT=APCDTOT+1

 +9                IF MF=1

                       SET APCDCNT=1

                       SET APCDTOT=1

                       DO READ

                       IF APCDY=""

                           SET APCDY="^"

                       QUIT 

 +10               IF MF>4

                       IF APCDCNT=5!(MF=APCDTOT)

                           DO READ

                           SET APCDCNT=0

                           QUIT 

 +11               IF MF<5

                       IF MF=APCDX

                           DO READ

                           SET APCDNT=0

                           IF APCDY]""

                               QUIT 

 +12               QUIT 

               End DoDot:1

 +13       QUIT 

READ      ;

 +1        KILL DIR,DIRUT

 +2        SET APCDY=""

 +3        WRITE !

 +4       ;W !,"Type ""^"" to STOP, press ENTER to continue the list or SELECT 1-"_APCDTOT

 +5        SET DIR("B")=$SELECT(MF=1:1,1:"")

           SET DIR(0)="NO^1:"_APCDTOT_":0"

 +6        SET DIR("A")="Type ""^"" to STOP or SELECT 1-"_APCDTOT

 +7        KILL DA

           DO ^DIR

           WRITE !

 +8        IF $DATA(DIRUT)

               SET APCDY="^"

 +9        IF Y=""

               SET APCDY=""

               QUIT 

 +10       SET APCDY=+Y

 +11 

*** ERROR ***

SUBE(X)   ;EP - does this subset exist?

 +1        NEW LST,Y,G

 +2        SET G=""

 +3        SET Y=$$SUBSET^BSTSAPI("LST",1552)

 +4        SET Y=0

           FOR 

               SET Y=$ORDER(LST(Y))

               IF Y'=+Y!(G)

                   QUIT 

               Begin DoDot:1

 +5                IF $PIECE(LST(Y),U,1)=X

                       SET G=1

 +6                QUIT 

               End DoDot:1

 +7        QUIT G