Routine: ACRFSS11

ACRFSS11 ;IHS/OIRM/DSD/THL,AEF - ACRFSS1 CON'T; [ 11/01/2001   9:44 AM ]

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

 ;;CONTINUATION OF ACRFSS1

ORDER ;EP;

 I $P(ACRDOC0,U,4)=35 D O1 Q

 W @IOF

 W !,"Select STANDARD ITEM by:"

 S DIR(0)="SO^1:Index Number;2:National Stock Number;3:Vendor;4:Vendor/Manufacturer Product Number;5:National Drug Code;6:Description/Keyword"

 D DIR^ACRFDIC

 I ($D(ACRQUIT)!(X="")),$D(ACRTXDA),ACRTXDA,$D(^ACRTXTYP(ACRTXDA,0)),$P(^(0),U,4)="ST" D  Q

 .W !!,"STOCK ISSUES CAN ONLY BE ORDERED FROM STANDARD ITEM INVENTORY."

 .H 2

 Q:$D(ACROUT)

 I X="" D O1 Q

 I Y=1 S ACRXREF="B",DIR("A")="Index NO............"

 I Y=2 S ACRXREF="NSN",DIR("A")="Nat'l Stock NO......"

 I Y=3 S ACRXREF="F",DIR("A")="Vendor.............."

 I Y=4 S ACRXREF="VON",DIR("A")="Vendor Product NO..."

 I Y=5 S ACRXREF="NDC",DIR("A")="Nat'l Drug Code....."

 I Y=6 S ACRXREF="C^D",DIR("A")="Description........."

 S DIR(0)="FO^2:17",DIR("?")="^S X=""??"",DIC=""^ACRITEM("",DIC(0)=""EQZ"",D=ACRXREF D DIC^ACRFDIC"

W !

 D DIR^ACRFDIC

 I $D(ACRQUIT)!$D(ACROUT) Q

 I Y="" K ACRQUIT D O1 Q

 S (ACRXX,X)=Y

 S DIC="^ACRITEM("

 S DIC(0)="EQZ"

 S D=ACRXREF

 D MIX^ACRFDIC

O2 I +Y>0 D  Q

 .S ACRJ=ACRJ+1

 .S ACRITMDA=+Y

 .S ACRX=$P(^ACRITEM(ACRITMDA,0),U)_" ("_$S($P(^(0),U,2)]"":$P(^(0),U,2),1:$P($G(^ACRITEM(ACRITMDA,2,1,0)),U))_")"

 .S ACRSSDR="[ACR STANDARD ITEM-2]"

 .D ADD1^ACRFSS1

 .D APCHK^ACRFSCHK

 .I $P(^ACRDOC(ACRDOCDA,0),U,4)=35,$E($G(^ACROBL(ACRDOCDA,"APV")))="A" Q

 .D APPROVE^ACRFSCHK

 W !!,"No STANDARD ITEM found"

 S DIR(0)="YO"

 S DIR("A")="Inquire to STANDARD ITEM file again"

 S DIR("B")="NO"

 K ACRQUIT,ACROUT

 D DIR^ACRFDIC

 K ACRQUIT

 G:Y=1 ORDER

O1 ;ADD NEW ITEM WHICH IS NOT FROM THE STANDARD ITEM FILE TO THE REQUEST

 K ACRXX

 D ADD2^ACRFSS1

 D APCHK^ACRFSCHK

 I $P(^ACRDOC(ACRDOCDA,0),U,4)=35,$E($G(^ACROBL(ACRDOCDA,"APV")))="A" I 1

 E  D APPROVE^ACRFSCHK

ORDER1 S DIR(0)="YO"

 S DIR("A")="Add another ITEM"

 S DIR("B")="NO"

 W !!

 D DIR^ACRFDIC

 G:Y=1 ORDER

ACRFSS11  ;IHS/OIRM/DSD/THL,AEF - ACRFSS1 CON'T; [ 11/01/2001   9:44 AM ]

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

 +2       ;;CONTINUATION OF ACRFSS1

ORDER     ;EP;

 +1        IF $PIECE(ACRDOC0,U,4)=35

               DO O1

               QUIT

 +2        WRITE @IOF

 +3        WRITE !,"Select STANDARD ITEM by:"

 +4        SET DIR(0)="SO^1:Index Number;2:National Stock Number;3:Vendor;4:Vendor/Manufacturer Product Number;5:National Drug Code;6:Description/Keyword"

 +5        DO DIR^ACRFDIC

 +6        IF ($DATA(ACRQUIT)!(X=""))

               IF $DATA(ACRTXDA)

                   IF ACRTXDA

                       IF $DATA(^ACRTXTYP(ACRTXDA,0))

                           IF $PIECE(^(0),U,4)="ST"

                               Begin DoDot:1

 +7                                WRITE !!,"STOCK ISSUES CAN ONLY BE ORDERED FROM STANDARD ITEM INVENTORY."

 +8                                HANG 2

                               End DoDot:1

                               QUIT

 +9        IF $DATA(ACROUT)

               QUIT

 +10       IF X=""

               DO O1

               QUIT

 +11       IF Y=1

               SET ACRXREF="B"

               SET DIR("A")="Index NO............"

 +12       IF Y=2

               SET ACRXREF="NSN"

               SET DIR("A")="Nat'l Stock NO......"

 +13       IF Y=3

               SET ACRXREF="F"

               SET DIR("A")="Vendor.............."

 +14       IF Y=4

               SET ACRXREF="VON"

               SET DIR("A")="Vendor Product NO..."

 +15       IF Y=5

               SET ACRXREF="NDC"

               SET DIR("A")="Nat'l Drug Code....."

 +16       IF Y=6

               SET ACRXREF="C^D"

               SET DIR("A")="Description........."

 +17       SET DIR(0)="FO^2:17"

           SET DIR("?")="^S X=""??"",DIC=""^ACRITEM("",DIC(0)=""EQZ"",D=ACRXREF D DIC^ACRFDIC"

 +18       WRITE !

 +19       DO DIR^ACRFDIC

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

               QUIT

 +21       IF Y=""

               KILL ACRQUIT

               DO O1

               QUIT

 +22       SET (ACRXX,X)=Y

 +23       SET DIC="^ACRITEM("

 +24       SET DIC(0)="EQZ"

 +25       SET D=ACRXREF

 +26       DO MIX^ACRFDIC

O2         IF +Y>0

               Begin DoDot:1

 +1                SET ACRJ=ACRJ+1

 +2                SET ACRITMDA=+Y

 +3                SET ACRX=$PIECE(^ACRITEM(ACRITMDA,0),U)_" ("_$SELECT($PIECE(^(0),U,2)]"":$PIECE(^(0),U,2),1:$PIECE($GET(^ACRITEM(ACRITMDA,2,1,0)),U))_")"

 +4                SET ACRSSDR="[ACR STANDARD ITEM-2]"

 +5                DO ADD1^ACRFSS1

 +6                DO APCHK^ACRFSCHK

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

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

                           QUIT

 +8                DO APPROVE^ACRFSCHK

               End DoDot:1

               QUIT

 +9        WRITE !!,"No STANDARD ITEM found"

 +10       SET DIR(0)="YO"

 +11       SET DIR("A")="Inquire to STANDARD ITEM file again"

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

 +13       KILL ACRQUIT,ACROUT

 +14       DO DIR^ACRFDIC

 +15       KILL ACRQUIT

 +16       IF Y=1

               GOTO ORDER

O1        ;ADD NEW ITEM WHICH IS NOT FROM THE STANDARD ITEM FILE TO THE REQUEST

 +1        KILL ACRXX

 +2        DO ADD2^ACRFSS1

 +3        DO APCHK^ACRFSCHK

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

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

                   IF 1

 +5       IF '$TEST

               DO APPROVE^ACRFSCHK

ORDER1     SET DIR(0)="YO"

 +1        SET DIR("A")="Add another ITEM"

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

 +3        WRITE !!

 +4        DO DIR^ACRFDIC

 +5        IF Y=1

               GOTO ORDER

 +6        QUIT

ACRFSS11.m