ACRFAPVS.m

ACRFAPVS ;IHS/OIRM/DSD/THL,AEF - SET APPROVAL SEQUENCE FOR EACH DOC;  [ 10/4/2005   9:44 AM ]

 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001

 ;;ROUTINE CONTROLS CREATION OF ALL APPROVAL SEQUENCES FOR DOCUMENTS

 ;;WHICH ARE SENT FOR APPROVAL

EN ;EP;TO KILL,CREATE AND UPDATE DOCUMENTS IN THE APPROVAL SEQUENCE

 I $E($G(IOST),1,2)="C-",$D(^ACRAPVS("AB",ACRDOCDA)),'$D(ACRSCHK),"^103^210^349^326^"'[(U_ACRREF_U),'$D(ACRCHANG) D DISPLAY Q:$D(ACRQUIT)

 I $P(^ACRDOC(ACRDOCDA,0),U,4)=35,$P($G(ACRDOC0),U,13) S ACRREFDA=$P(ACRDOC0,U,13)

 E  S ACRREFDA=$P(^ACRDOC(ACRDOCDA,0),U,13)

 S ACRCANDA=$P(^ACRDOC(ACRDOCDA,"REQ"),U,10)

 S ACRREF=$P(^AUTTDOCR(ACRREFDA,0),U)

 D KILL:$D(^ACRAPVS("AB",ACRDOCDA))

 D CREATE

 D UP^ACRFPRC3

EXIT K ACRORDER,ACRAPDA,ACRTYPDA,ACRTX,ACRFINAL,ACRGLB,ACRPC,ACRSDBUS

 Q

CREATE ;CREATES NEW APPROVALS FOR A DOCUMENT

 S ACRDOC0=^ACRDOC(ACRDOCDA,0)

 S ACRLBDA=$P(ACRDOC0,U,6)

 I ACRREFX=130,$E(^ACROBL(ACRDOCDA,"APV"))="A",$P(^("APV"),U)="A" S ACRREFX=600

 I ACRREFX=103!(ACRREFX=349)!(ACRREFX=326)!(ACRREFX=600) S ACRTX=$S(ACRREFX=600:19,1:11)

 E  D

 .S ACRTX=$P(ACRDOC0,U,4)

 .S ACRTX=$S($P(ACRDOC0,U,19):31,1:ACRTX)

 I '$G(ACRADA) D  Q:'$G(ACRADA)

 .I $G(ACRPODA) S ACRADA=$P(^ACRPO(ACRPODA,0),U,19)

 .I '$G(ACRPODA) D

 ..S ACRPODA=$P(ACRDOC0,U,8)

 ..S:ACRPODA ACRADA=$P(^ACRPO(ACRPODA,0),U,19)

 ..S:'ACRADA ACRADA=1

 S ACRAPVT=0

 F  S ACRAPVT=$O(^ACRDOCA("AC",ACRADA,ACRTX,ACRAPVT)) Q:'ACRAPVT  D

 .I ACRAPVT=46!(ACRAPVT=1) D SADBUS I '$D(ACRSDBUS),ACRAPVT=46 Q

 .I ACRAPVT=33!(ACRAPVT=34),$P(^AUTTCAN(ACRCANDA,0),U,3)'=1 Q

 .S ACRORDER=$O(^ACRDOCA("AC",ACRADA,ACRTX,ACRAPVT,""))

 .S ACRTYPDA=$O(^ACRDOCA("AC",ACRADA,ACRTX,ACRAPVT,ACRORDER,""))

 .S ACRFINAL=$P(^ACRDOCA(ACRTYPDA,0),U,4)

 .S ACRGLB=$P(^ACRAPVT(ACRAPVT,"DT"),U)

 .S ACRPC=$P(^ACRAPVT(ACRAPVT,"DT"),U,2)

 .S ACRUSER=$P($G(^ACRDOC(ACRDOCDA,ACRGLB)),U,ACRPC)

 .I ACRAPVT=1,'$D(ACRSDBUS) S ACRORDER=1

 .I ACRTX=35,ACRFINAL="Y" D

 ..D PROP

 ..S:$D(ACRPROP) ACRPROP=ACRORDER,ACRORDER=ACRORDER+2

 .D SETAPP

 ; Hardcode approval signature sequence for Property Clearance and Local Property Manager on 3100 CC requests

 I $D(ACRPROP) D

 .F ACRORDER=ACRPROP

 .; Property Clearance

 .S ACRAPVT=31

 .S ACRFINAL=""

 .S ACRGLB=$P(^ACRAPVT(ACRAPVT,"DT"),U)

 .S ACRPC=$P(^ACRAPVT(ACRAPVT,"DT"),U,2)

 .S ACRUSER=$P($G(^ACRDOC(ACRDOCDA,ACRGLB)),U,ACRPC)

 .D SETAPP

 .K ACRPROP                            ; ACR*2.1*19.06  IM18610

 .Q                                    ; ACR*2.1*19.06  IM18610

 .S ACRORDER=ACRPROP+1

 .; Local Property Manager

 .S ACRAPVT=6

 .S ACRFINAL=""

 .S ACRGLB=$P(^ACRAPVT(ACRAPVT,"DT"),U)

 .S ACRPC=$P(^ACRAPVT(ACRAPVT,"DT"),U,2)

 .S ACRUSER=$P($G(^ACRDOC(ACRDOCDA,ACRGLB)),U,ACRPC)

 .D SETAPP

 .K ACRPROP

 Q

SETAPP ;EP;TO CREATE APPROVAL ENTRY

 S X=ACRDOCDA

 S DIC="^ACRAPVS("

 S DIC(0)="L"

 S DIC("DR")="5////"_ACRFINAL_";.03////"_ACRAPVT_";.04////"_ACRORDER_";.05////"_ACRLBDA_";.06////"_ACRREFDA_";2////"_$S(ACRUSER:ACRUSER,1:"")_";.08////"_DUZ

 S:$D(ACRDATE) DIC("DR")=DIC("DR")_";3////"_ACRDATE

 S:$D(ACRRDATE) DIC("DR")=DIC("DR")_";8////"_ACRRDATE

 S:$D(ACRRRNO) DIC("DR")=DIC("DR")_";9////"_ACRRRNO

 K ACRORDER,ACRTYPDA,ACRGLB,ACRPC

 I ACRAPVT=41 D  I $D(ACRQUIT)!$D(ACROUT) K ACRQUIT Q

 .N ACRAPDA

 .S ACRAPDA=0

 .F  S ACRAPDA=$O(^ACRAPVS("ANXT",ACRAPVT,ACRUSER,ACRAPDA)) Q:'ACRAPDA  I ^(ACRAPDA)=ACRDOCDA S ACRQUIT="" Q

 D FILE^ACRFDIC

 Q

KILL ;EP;TO KILL EXISTING APPROVALS FOR A DOCUMENT

 N ACRAPVT,ACRINDV,ACRAPDA,X,Y

 S ACRAPDA=0

 S DIK="^ACRAPVS("

 F  S ACRAPDA=$O(^ACRAPVS("AB",ACRDOCDA,ACRAPDA)) Q:'ACRAPDA  D

 .I '$D(^ACRAPVS(ACRAPDA,0))!'$D(^ACRAPVS(ACRAPDA,"DT")) D  Q

 ..K ^ACRAPVS(ACRAPDA,"DT")

 ..K ^ACRAPVS(ACRAPDA,0),^ACRAPVS("AB",ACRDOCDA,ACRAPDA)

 .S X=^ACRAPVS(ACRAPDA,0)

 .S Y=^ACRAPVS(ACRAPDA,"DT")

 .Q:ACRREFDA'=$P(X,U,6)

 .S ACRAPVT=$P(X,U,3)

 .S ACRORD=$P(X,U,4)

 .S ACRINDV=$P(Y,U,2)

 .K ^ACRAPVS("ANXT",+ACRAPVT,+ACRINDV,+ACRAPDA)

 .D NOW^%DTC

 .S DA=ACRAPDA

 .S DIE="^ACRAPVS("

 .S DR=".07////"_ACRDOCDA_";.1////"_%_";.09////"_DUZ

 .D DIE^ACRFDIC

 .K ^ACRAPVS("AB",ACRDOCDA,+ACRAPDA)

 .K ^ACRAPVS("AORDR",ACRDOCDA,+ACRORD,+ACRAPDA)

 .K ^ACRAPVS("AC",ACRDOCDA,+ACRINDV,+ACRAPDA)

 .K ACRAPVT,ACRORD

 K ^ACRAPVS("AORDR",ACRDOCDA)

 I $D(^ACRTVAL(ACRDOCDA)) D

 . S DA=ACRDOCDA

 . S DIE="^ACRTVAL("

 . S DR=".04///^S X=""@"""

 . D ^DIE

 Q

SADBUS ;EP;TO DETERMIN IF SADBUS SIGNATURE IS REQUIRED

 N X

 S X=$E($P(^ACRDOC(ACRDOCDA,"PO"),U,2))

 Q:X="G"!(X="V")

 I $P($G(^ACRDOC(ACRDOCDA,"PO")),U,5),$D(^AUTTVNDR($P(^("PO"),U,5),11)),$P(^(11),U,27)="A1" Q

 N X,Y

 S (X,Y)=0

 F  S X=$O(^ACRSS("J",ACRDOCDA,X)) Q:'X  S Y=Y+$P($G(^ACRSS(X,"DT")),U,4)

 S:Y>2499.9999 ACRSDBUS=""

 Q

DISPLAY ;DISPLAY APPROVALS PRIOR TO KILLING AND RECREATING APPROVALS

 K ACRQUIT

 N X

 S X=0

 F  S X=$O(^ACRAPVS("AB",ACRDOCDA,X)) Q:'X  I $G(ACRREFDA)=$P($G(^ACRAPVS(X,0)),U,6) S ACRQUIT="" Q

 Q:'$D(ACRQUIT)

 K ACRQUIT

 D ^ACRFPAPV

 S DIR(0)="YO"

 S DIR("A",1)="Are you certain you want to send"

 S DIR("A")="this document for approval"

 S DIR("B")="NO"

 W !!,"Sending this document for approval will delete any approvals currently listed."

 W !

 D DIR^ACRFDIC

 I $G(Y)'=1 S ACRQUIT=""

 Q

PROP ;DETERMINE IF CREDIT CARD ITEMS INCLUDE EQUIPMENT AND INCLUDE

 ;PROPERTY MGT SIGNATURE IF SO

 K ACRPROP

 N X,Y

 S X=0

 F  S X=$O(^ACRSS($S(ACRREFX=116&($P(^ACRDOC(ACRDOCDA,0),U,4)'=35):"C",ACRREFX=116&($P(^ACRDOC(ACRDOCDA,0),U,4)=35&($P($G(^ACROBL(ACRDOCDA,"APV")),U)'="A")):"C",1:"J"),ACRDOCDA,X)) Q:'X  D

 .S Y=$P($G(^ACRSS(X,0)),U,4)

 .S Y=$P($G(^AUTTOBJC(+Y,0)),U)

 .I $E(Y,1,2)=31 S ACRPROP=""

 Q

ACRFAPVS  ;IHS/OIRM/DSD/THL,AEF - SET APPROVAL SEQUENCE FOR EACH DOC;  [ 10/4/2005   9:44 AM ]

 +1       ;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001

 +2       ;;ROUTINE CONTROLS CREATION OF ALL APPROVAL SEQUENCES FOR DOCUMENTS

 +3       ;;WHICH ARE SENT FOR APPROVAL

EN        ;EP;TO KILL,CREATE AND UPDATE DOCUMENTS IN THE APPROVAL SEQUENCE

 +1        IF $EXTRACT($GET(IOST),1,2)="C-"

               IF $DATA(^ACRAPVS("AB",ACRDOCDA))

                   IF '$DATA(ACRSCHK)

                       IF "^103^210^349^326^"'[(U_ACRREF_U)

                           IF '$DATA(ACRCHANG)

                               DO DISPLAY

                               IF $DATA(ACRQUIT)

                                   QUIT 

 +2        IF $PIECE(^ACRDOC(ACRDOCDA,0),U,4)=35

               IF $PIECE($GET(ACRDOC0),U,13)

                   SET ACRREFDA=$PIECE(ACRDOC0,U,13)

 +3       IF '$TEST

               SET ACRREFDA=$PIECE(^ACRDOC(ACRDOCDA,0),U,13)

 +4        SET ACRCANDA=$PIECE(^ACRDOC(ACRDOCDA,"REQ"),U,10)

 +5        SET ACRREF=$PIECE(^AUTTDOCR(ACRREFDA,0),U)

 +6        IF $DATA(^ACRAPVS("AB",ACRDOCDA))

               DO KILL

 +7        DO CREATE

 +8        DO UP^ACRFPRC3

EXIT       KILL ACRORDER,ACRAPDA,ACRTYPDA,ACRTX,ACRFINAL,ACRGLB,ACRPC,ACRSDBUS

 +1        QUIT 

CREATE    ;CREATES NEW APPROVALS FOR A DOCUMENT

 +1        SET ACRDOC0=^ACRDOC(ACRDOCDA,0)

 +2        SET ACRLBDA=$PIECE(ACRDOC0,U,6)

 +3        IF ACRREFX=130

               IF $EXTRACT(^ACROBL(ACRDOCDA,"APV"))="A"

                   IF $PIECE(^("APV"),U)="A"

                       SET ACRREFX=600

 +4        IF ACRREFX=103!(ACRREFX=349)!(ACRREFX=326)!(ACRREFX=600)

               SET ACRTX=$SELECT(ACRREFX=600:19,1:11)

 +5       IF '$TEST

               Begin DoDot:1

 +6                SET ACRTX=$PIECE(ACRDOC0,U,4)

 +7                SET ACRTX=$SELECT($PIECE(ACRDOC0,U,19):31,1:ACRTX)

               End DoDot:1

 +8        IF '$GET(ACRADA)

               Begin DoDot:1

 +9                IF $GET(ACRPODA)

                       SET ACRADA=$PIECE(^ACRPO(ACRPODA,0),U,19)

 +10               IF '$GET(ACRPODA)

                       Begin DoDot:2

 +11                       SET ACRPODA=$PIECE(ACRDOC0,U,8)

 +12                       IF ACRPODA

                               SET ACRADA=$PIECE(^ACRPO(ACRPODA,0),U,19)

 +13                       IF 'ACRADA

                               SET ACRADA=1

                       End DoDot:2

               End DoDot:1

               IF '$GET(ACRADA)

                   QUIT 

 +14       SET ACRAPVT=0

 +15       FOR 

               SET ACRAPVT=$ORDER(^ACRDOCA("AC",ACRADA,ACRTX,ACRAPVT))

               IF 'ACRAPVT

                   QUIT 

               Begin DoDot:1

 +16               IF ACRAPVT=46!(ACRAPVT=1)

                       DO SADBUS

                       IF '$DATA(ACRSDBUS)

                           IF ACRAPVT=46

                               QUIT 

 +17               IF ACRAPVT=33!(ACRAPVT=34)

                       IF $PIECE(^AUTTCAN(ACRCANDA,0),U,3)'=1

                           QUIT 

 +18               SET ACRORDER=$ORDER(^ACRDOCA("AC",ACRADA,ACRTX,ACRAPVT,""))

 +19               SET ACRTYPDA=$ORDER(^ACRDOCA("AC",ACRADA,ACRTX,ACRAPVT,ACRORDER,""))

 +20               SET ACRFINAL=$PIECE(^ACRDOCA(ACRTYPDA,0),U,4)

 +21               SET ACRGLB=$PIECE(^ACRAPVT(ACRAPVT,"DT"),U)

 +22               SET ACRPC=$PIECE(^ACRAPVT(ACRAPVT,"DT"),U,2)

 +23               SET ACRUSER=$PIECE($GET(^ACRDOC(ACRDOCDA,ACRGLB)),U,ACRPC)

 +24               IF ACRAPVT=1

                       IF '$DATA(ACRSDBUS)

                           SET ACRORDER=1

 +25               IF ACRTX=35

                       IF ACRFINAL="Y"

                           Begin DoDot:2

 +26                           DO PROP

 +27                           IF $DATA(ACRPROP)

                                   SET ACRPROP=ACRORDER

                                   SET ACRORDER=ACRORDER+2

                           End DoDot:2

 +28               DO SETAPP

               End DoDot:1

 +29      ; Hardcode approval signature sequence for Property Clearance and Local Property Manager on 3100 CC requests

 +30       IF $DATA(ACRPROP)

               Begin DoDot:1

 +31               FOR ACRORDER=ACRPROP

 +32      ; Property Clearance

 +33               SET ACRAPVT=31

 +34               SET ACRFINAL=""

 +35               SET ACRGLB=$PIECE(^ACRAPVT(ACRAPVT,"DT"),U)

 +36               SET ACRPC=$PIECE(^ACRAPVT(ACRAPVT,"DT"),U,2)

 +37               SET ACRUSER=$PIECE($GET(^ACRDOC(ACRDOCDA,ACRGLB)),U,ACRPC)

 +38               DO SETAPP

 +39      ; ACR*2.1*19.06  IM18610

                   KILL ACRPROP

 +40      ; ACR*2.1*19.06  IM18610

                   QUIT 

 +41               SET ACRORDER=ACRPROP+1

 +42      ; Local Property Manager

 +43               SET ACRAPVT=6

 +44               SET ACRFINAL=""

 +45               SET ACRGLB=$PIECE(^ACRAPVT(ACRAPVT,"DT"),U)

 +46               SET ACRPC=$PIECE(^ACRAPVT(ACRAPVT,"DT"),U,2)

 +47               SET ACRUSER=$PIECE($GET(^ACRDOC(ACRDOCDA,ACRGLB)),U,ACRPC)

 +48               DO SETAPP

 +49               KILL ACRPROP

               End DoDot:1

 +50       QUIT 

SETAPP    ;EP;TO CREATE APPROVAL ENTRY

 +1        SET X=ACRDOCDA

 +2        SET DIC="^ACRAPVS("

 +3        SET DIC(0)="L"

 +4        SET DIC("DR")="5////"_ACRFINAL_";.03////"_ACRAPVT_";.04////"_ACRORDER_";.05////"_ACRLBDA_";.06////"_ACRREFDA_";2////"_$SELECT(ACRUSER:ACRUSER,1:"")_";.08////"_DUZ

 +5        IF $DATA(ACRDATE)

               SET DIC("DR")=DIC("DR")_";3////"_ACRDATE

 +6        IF $DATA(ACRRDATE)

               SET DIC("DR")=DIC("DR")_";8////"_ACRRDATE

 +7        IF $DATA(ACRRRNO)

               SET DIC("DR")=DIC("DR")_";9////"_ACRRRNO

 +8        KILL ACRORDER,ACRTYPDA,ACRGLB,ACRPC

 +9        IF ACRAPVT=41

               Begin DoDot:1

 +10               NEW ACRAPDA

 +11               SET ACRAPDA=0

 +12               FOR 

                       SET ACRAPDA=$ORDER(^ACRAPVS("ANXT",ACRAPVT,ACRUSER,ACRAPDA))

                       IF 'ACRAPDA

                           QUIT 

                       IF ^(ACRAPDA)=ACRDOCDA

                           SET ACRQUIT=""

                           QUIT 

               End DoDot:1

               IF $DATA(ACRQUIT)!$DATA(ACROUT)

                   KILL ACRQUIT

                   QUIT 

 +13       DO FILE^ACRFDIC

 +14       QUIT 

KILL      ;EP;TO KILL EXISTING APPROVALS FOR A DOCUMENT

 +1        NEW ACRAPVT,ACRINDV,ACRAPDA,X,Y

 +2        SET ACRAPDA=0

 +3        SET DIK="^ACRAPVS("

 +4        FOR 

               SET ACRAPDA=$ORDER(^ACRAPVS("AB",ACRDOCDA,ACRAPDA))

               IF 'ACRAPDA

                   QUIT 

               Begin DoDot:1

 +5                IF '$DATA(^ACRAPVS(ACRAPDA,0))!'$DATA(^ACRAPVS(ACRAPDA,"DT"))

                       Begin DoDot:2

 +6                        KILL ^ACRAPVS(ACRAPDA,"DT")

 +7                        KILL ^ACRAPVS(ACRAPDA,0),^ACRAPVS("AB",ACRDOCDA,ACRAPDA)

                       End DoDot:2

                       QUIT 

 +8                SET X=^ACRAPVS(ACRAPDA,0)

 +9                SET Y=^ACRAPVS(ACRAPDA,"DT")

 +10               IF ACRREFDA'=$PIECE(X,U,6)

                       QUIT 

 +11               SET ACRAPVT=$PIECE(X,U,3)

 +12               SET ACRORD=$PIECE(X,U,4)

 +13               SET ACRINDV=$PIECE(Y,U,2)

 +14               KILL ^ACRAPVS("ANXT",+ACRAPVT,+ACRINDV,+ACRAPDA)

 +15               DO NOW^%DTC

 +16               SET DA=ACRAPDA

 +17               SET DIE="^ACRAPVS("

 +18               SET DR=".07////"_ACRDOCDA_";.1////"_%_";.09////"_DUZ

 +19               DO DIE^ACRFDIC

 +20               KILL ^ACRAPVS("AB",ACRDOCDA,+ACRAPDA)

 +21               KILL ^ACRAPVS("AORDR",ACRDOCDA,+ACRORD,+ACRAPDA)

 +22               KILL ^ACRAPVS("AC",ACRDOCDA,+ACRINDV,+ACRAPDA)

 +23               KILL ACRAPVT,ACRORD

               End DoDot:1

 +24       KILL ^ACRAPVS("AORDR",ACRDOCDA)

 +25       IF $DATA(^ACRTVAL(ACRDOCDA))

               Begin DoDot:1

 +26               SET DA=ACRDOCDA

 +27               SET DIE="^ACRTVAL("

 +28               SET DR=".04///^S X=""@"""

 +29               DO ^DIE

               End DoDot:1

 +30       QUIT 

SADBUS    ;EP;TO DETERMIN IF SADBUS SIGNATURE IS REQUIRED

 +1        NEW X

 +2        SET X=$EXTRACT($PIECE(^ACRDOC(ACRDOCDA,"PO"),U,2))

 +3        IF X="G"!(X="V")

               QUIT 

 +4        IF $PIECE($GET(^ACRDOC(ACRDOCDA,"PO")),U,5)

               IF $DATA(^AUTTVNDR($PIECE(^("PO"),U,5),11))

                   IF $PIECE(^(11),U,27)="A1"

                       QUIT 

 +5        NEW X,Y

 +6        SET (X,Y)=0

 +7        FOR 

               SET X=$ORDER(^ACRSS("J",ACRDOCDA,X))

               IF 'X

                   QUIT 

               SET Y=Y+$PIECE($GET(^ACRSS(X,"DT")),U,4)

 +8        IF Y>2499.9999

               SET ACRSDBUS=""

 +9        QUIT 

DISPLAY   ;DISPLAY APPROVALS PRIOR TO KILLING AND RECREATING APPROVALS

 +1        KILL ACRQUIT

 +2        NEW X

 +3        SET X=0

 +4        FOR 

               SET X=$ORDER(^ACRAPVS("AB",ACRDOCDA,X))

               IF 'X

                   QUIT 

               IF $GET(ACRREFDA)=$PIECE($GET(^ACRAPVS(X,0)),U,6)

                   SET ACRQUIT=""

                   QUIT 

 +5        IF '$DATA(ACRQUIT)

               QUIT 

 +6        KILL ACRQUIT

 +7        DO ^ACRFPAPV

 +8        SET DIR(0)="YO"

 +9        SET DIR("A",1)="Are you certain you want to send"

 +10       SET DIR("A")="this document for approval"

 +11       SET DIR("B")="NO"

 +12       WRITE !!,"Sending this document for approval will delete any approvals currently listed."

 +13       WRITE !

 +14       DO DIR^ACRFDIC

 +15       IF $GET(Y)'=1

               SET ACRQUIT=""

 +16       QUIT 

PROP      ;DETERMINE IF CREDIT CARD ITEMS INCLUDE EQUIPMENT AND INCLUDE

 +1       ;PROPERTY MGT SIGNATURE IF SO

 +2        KILL ACRPROP

 +3        NEW X,Y

 +4        SET X=0

 +5        FOR 

               SET X=$ORDER(^ACRSS($SELECT(ACRREFX=116&($PIECE(^ACRDOC(ACRDOCDA,0),U,4)'=35):"C",ACRREFX=116&($PIECE(^ACRDOC(ACRDOCDA,0),U,4)=35&($PIECE($GET(^ACROBL(ACRDOCDA,"APV")),U)'="A")):"C",1:"J"),ACRDOCDA,X))

               IF 'X

                   QUIT 

               Begin DoDot:1

 +6                SET Y=$PIECE($GET(^ACRSS(X,0)),U,4)

 +7                SET Y=$PIECE($GET(^AUTTOBJC(+Y,0)),U)

 +8                IF $EXTRACT(Y,1,2)=31

                       SET ACRPROP=""

               End DoDot:1

 +9        QUIT