PSALFM.m

PSALFM ;BIR/LTL-Controlled Connection by FSN Match ;7/23/97

 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97

 ;

 D DT^DICRW

START ;compiles data for edit

EXPL W !,"I'll loop through the FSNs in your DRUG file.",!,"If I find a match in the ITEM MASTER file, I'll let you know.",!

 N D0,D1,DA,DIC,DIE,DIR,DIRUT,DIW,DIWF,DIWL,DIWR,DIWT,DLAYGO,DR,DTOUT,DUOUT,PSA,PSAD,PSADD,PSAF,PSAFSN,PSAIT,PSAOUT,X,Y S (PSA,PSAD)=0

LOOP F  S PSAD=$O(^PSDRUG(PSAD)) G:'PSAD!($D(PSAOUT)) END I $P($G(^PSDRUG(PSAD,0)),U,6)]"",'$O(^PSDRUG(PSAD,441,0)),'$D(^PSDRUG(PSAD,"I")) D  G:$G(PSAOUT) END

 .I $Y+5>IOSL S DIR(0)="E" D ^DIR K DIR S:'Y PSAOUT=1 W @IOF Q

FORM .S PSAFSN=$P(^PSDRUG(PSAD,0),U,6) W !,PSAFSN D:$O(^PRC(441,"BB",PSAFSN,0))

 ..N PSADD S PSAIT=$O(^PRC(441,"BB",PSAFSN,"")) D  W !,$E($P(^PSDRUG(PSAD,0),U),1,39)

USED ...I $O(^PSDRUG("AB",PSAIT,"")) S PSADD=$O(^PSDRUG("AB",PSAIT,"")) W !,"**"_$P(^PSDRUG(PSADD,0),U)_" is already linked to Item #"_PSAIT_"**"

INAC ...I $E($G(^PRC(441,PSAIT,3)),1)=1 W !,"Sorry, Item #"_PSAIT_" is INACTIVE, can't link.",! S PSADD=""

 ..I $L($G(^PRC(441,+PSAIT,1,1,0)))<40,'$O(^PRC(441,+PSAIT,1,1)) W ?40,$G(^PRC(441,+PSAIT,1,1,0)),! G SH

 ..K ^UTILITY($J,"W") S DIWL=40,DIWR=80,DIWF="W"

 ..F  S PSA=$O(^PRC(441,+PSAIT,1,PSA)) Q:'PSA  S X=$G(^PRC(441,+PSAIT,1,PSA,0)) D ^DIWP

 ..D ^DIWW S PSA=0

SH ..D:'$D(PSADD) OFFER

END I '$G(PSAOUT) S DIR(0)="EA",DIR("A")="Done with FSN's.  Press <RET> to return to the menu." D ^DIR

QUIT Q

OFFER S DIR(0)="Y",DIR("A")="Do we have a match",DIR("B")="Yes" D ^DIR K DIR S:$D(DIRUT) PSAOUT=1 Q:'Y  D

OK S DIE=50,DA=PSAD,DR="441///^S X=PSAIT" D ^DIE W "  Linked to Item #"_PSAIT

PSALFM    ;BIR/LTL-Controlled Connection by FSN Match ;7/23/97

 +1       ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97

 +2       ;

 +3        DO DT^DICRW

START     ;compiles data for edit

EXPL       WRITE !,"I'll loop through the FSNs in your DRUG file.",!,"If I find a match in the ITEM MASTER file, I'll let you know.",!

 +1        NEW D0,D1,DA,DIC,DIE,DIR,DIRUT,DIW,DIWF,DIWL,DIWR,DIWT,DLAYGO,DR,DTOUT,DUOUT,PSA,PSAD,PSADD,PSAF,PSAFSN,PSAIT,PSAOUT,X,Y

           SET (PSA,PSAD)=0

LOOP       FOR 

               SET PSAD=$ORDER(^PSDRUG(PSAD))

               IF 'PSAD!($DATA(PSAOUT))

                   GOTO END

               IF $PIECE($GET(^PSDRUG(PSAD,0)),U,6)]""

                   IF '$ORDER(^PSDRUG(PSAD,441,0))

                       IF '$DATA(^PSDRUG(PSAD,"I"))

                           Begin DoDot:1

 +1                            IF $Y+5>IOSL

                                   SET DIR(0)="E"

                                   DO ^DIR

                                   KILL DIR

                                   IF 'Y

                                       SET PSAOUT=1

                                   WRITE @IOF

                                   QUIT 

FORM                           SET PSAFSN=$PIECE(^PSDRUG(PSAD,0),U,6)

                               WRITE !,PSAFSN

                               IF $ORDER(^PRC(441,"BB",PSAFSN,0))

                                   Begin DoDot:2

 +1                                    NEW PSADD

                                       SET PSAIT=$ORDER(^PRC(441,"BB",PSAFSN,""))

                                       Begin DoDot:3

USED                                       IF $ORDER(^PSDRUG("AB",PSAIT,""))

                                               SET PSADD=$ORDER(^PSDRUG("AB",PSAIT,""))

                                               WRITE !,"**"_$PIECE(^PSDRUG(PSADD,0),U)_" is already linked to Item #"_PSAIT_"**"

INAC                                       IF $EXTRACT($GET(^PRC(441,PSAIT,3)),1)=1

                                               WRITE !,"Sorry, Item #"_PSAIT_" is INACTIVE, can't link.",!

                                               SET PSADD=""

                                       End DoDot:3

                                       WRITE !,$EXTRACT($PIECE(^PSDRUG(PSAD,0),U),1,39)

 +1                                    IF $LENGTH($GET(^PRC(441,+PSAIT,1,1,0)))<40

                                           IF '$ORDER(^PRC(441,+PSAIT,1,1))

                                               WRITE ?40,$GET(^PRC(441,+PSAIT,1,1,0)),!

                                               GOTO SH

 +2                                    KILL ^UTILITY($JOB,"W")

                                       SET DIWL=40

                                       SET DIWR=80

                                       SET DIWF="W"

 +3                                    FOR 

                                           SET PSA=$ORDER(^PRC(441,+PSAIT,1,PSA))

                                           IF 'PSA

                                               QUIT 

                                           SET X=$GET(^PRC(441,+PSAIT,1,PSA,0))

                                           DO ^DIWP

 +4                                    DO ^DIWW

                                       SET PSA=0

SH                                     IF '$DATA(PSADD)

                                           DO OFFER

                                   End DoDot:2

                           End DoDot:1

                           IF $GET(PSAOUT)

                               GOTO END

END        IF '$GET(PSAOUT)

               SET DIR(0)="EA"

               SET DIR("A")="Done with FSN's.  Press <RET> to return to the menu."

               DO ^DIR

QUIT       QUIT 

OFFER      SET DIR(0)="Y"

           SET DIR("A")="Do we have a match"

           SET DIR("B")="Yes"

           DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               SET PSAOUT=1

           IF 'Y

               QUIT 

           Begin DoDot:1

           End DoDot:1

OK         SET DIE=50

           SET DA=PSAD

           SET DR="441///^S X=PSAIT"

           DO ^DIE

           WRITE "  Linked to Item #"_PSAIT