Routine: PSDUSER

PSDUSER ;BIR/LTL- MFI - NDES USERS Message builder for HL7 ; 16 Aug 95

 ;;3.0; CONTROLLED SUBSTANCES ;**18**;13 Feb 97

 N DIC,DIR,DIRUT,DTOUT,DUOUT,PSD,PSDOUT,X,Y

PIC S DIC="^VA(200,",DIC(0)="AEMQ"

 S DIC("S")="I $S('$P($G(^(0)),U,11):1,$P($G(^(0)),U,11)>DT:1,1:0)"

 F  S DIC("W")="W ""  USER ID:  "",Y,""  "",$P($G(^DIC(3.1,+$P($G(^VA(200,Y,0)),U,9),0)),U)" D ^DIC Q:Y<1  S PSD($P(Y,U,2))=+Y_U_$P($G(^VA(200,+Y,.13)),U)

 K DIC Q:$D(DTOUT)!($D(DUOUT))!($O(PSD(0))']"")

 S PSD(1)=$O(PSD(0)) G:$O(PSD(PSD(1)))']"" HL

PRI S DIR(0)="Y",DIR("A")="Would you like to print a list of the names you are about to transmit",DIR("B")="Yes"

 S DIR("?")="You will be able to add or remove names from the list after reviewing"

 W ! D ^DIR K DIR Q:$D(DIRUT)  G:Y=0 HL

 K IO("Q") N %ZIS,IOP,POP S %ZIS="Q" W ! D ^%ZIS Q:POP

 I $D(IO("Q")) N ZTIO,ZTDTH,ZTSK S ZTRTN="Q^PSDUSER",ZTDESC="CS Print User List for NDES interface",ZTSAVE("PSD*")="" D ^%ZTLOAD,HOME^%ZIS G HL

Q N LN,PG S (PG,PSDOUT)=0 D HEADER S PSD=1

 F  S PSD=$O(PSD(PSD)) Q:PSD']""  D:$Y+2>IOSL HEADER Q:PSDOUT  W !,PSD,?32,+PSD(PSD),?42,$P(PSD(PSD),U,2)

HL N HLERR,HLEVN,HLNDAP,HLMTN,HLFS,HLECH,HLSDATA,HLSDT,HLSEC,HLCHAR,HLDA,HLDAN,HLDAP,HLDT,HLDT1,HLNDAP0,HLPID,HLQ,HLVER

 S HLNDAP="PSD-NDES" D INIT^HLTRANS I $D(HLERR) D KILL^HLTRANS Q

 S HLMTN="MFN",HLEVN=1,HLSDT=DT

MFI S ^TMP("HLS",$J,HLSDT,1)="MFI"_HLFS_200_$E(HLECH)_"NEW PERSON"_HLFS_"PSD-CS"_HLFS_"UPD"_HLFS_HLDT1_HLFS_HLFS_"AL",PSD=0,PSD(1)=2

MFE F  S PSD=$O(PSD(PSD)) Q:PSD']""  S ^TMP("HLS",$J,HLSDT,PSD(1))="MFE"_HLFS_"MUP"_HLFS_HLFS_HLFS_PSD(PSD)_$E(HLECH)_PSD,PSD(1)=PSD(1)+1

SEND D EN^HLTRANS Q

HEADER I $E(IOST,1,2)'="P-",PG S DIR(0)="E" D ^DIR K DIR I 'Y S PSDOUT=1 Q

 I $$S^%ZTLOAD W !!,"Task#",$G(ZTSK),", ",$G(ZTDESC)," was stopped by ",$P($G(^VA(200,+$G(DUZ),0)),U),"." S PSDOUT=1

 W:$Y @IOF S $P(LN,"-",81)="",PG=PG+1

 W !,"User List for Narcotic Dispensing Equipment System",?70

 W "Page:  ",PG,!,LN,!?5,"NAME",?32,"USER ID",?42,"PHONE NUMBER",!,LN

PSDUSER   ;BIR/LTL- MFI - NDES USERS Message builder for HL7 ; 16 Aug 95

 +1       ;;3.0; CONTROLLED SUBSTANCES ;**18**;13 Feb 97

 +2        NEW DIC,DIR,DIRUT,DTOUT,DUOUT,PSD,PSDOUT,X,Y

PIC        SET DIC="^VA(200,"

           SET DIC(0)="AEMQ"

 +1        SET DIC("S")="I $S('$P($G(^(0)),U,11):1,$P($G(^(0)),U,11)>DT:1,1:0)"

 +2        FOR

               SET DIC("W")="W ""  USER ID:  "",Y,""  "",$P($G(^DIC(3.1,+$P($G(^VA(200,Y,0)),U,9),0)),U)"

               DO ^DIC

               IF Y<1

                   QUIT

               SET PSD($PIECE(Y,U,2))=+Y_U_$PIECE($GET(^VA(200,+Y,.13)),U)

 +3        KILL DIC

           IF $DATA(DTOUT)!($DATA(DUOUT))!($ORDER(PSD(0))']"")

               QUIT

 +4        SET PSD(1)=$ORDER(PSD(0))

           IF $ORDER(PSD(PSD(1)))']""

               GOTO HL

PRI        SET DIR(0)="Y"

           SET DIR("A")="Would you like to print a list of the names you are about to transmit"

           SET DIR("B")="Yes"

 +1        SET DIR("?")="You will be able to add or remove names from the list after reviewing"

 +2        WRITE !

           DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               QUIT

           IF Y=0

               GOTO HL

 +3        KILL IO("Q")

           NEW %ZIS,IOP,POP

           SET %ZIS="Q"

           WRITE !

           DO ^%ZIS

           IF POP

               QUIT

 +4        IF $DATA(IO("Q"))

               NEW ZTIO,ZTDTH,ZTSK

               SET ZTRTN="Q^PSDUSER"

               SET ZTDESC="CS Print User List for NDES interface"

               SET ZTSAVE("PSD*")=""

               DO ^%ZTLOAD

               DO HOME^%ZIS

               GOTO HL

Q          NEW LN,PG

           SET (PG,PSDOUT)=0

           DO HEADER

           SET PSD=1

 +1        FOR

               SET PSD=$ORDER(PSD(PSD))

               IF PSD']""

                   QUIT

               IF $Y+2>IOSL

                   DO HEADER

               IF PSDOUT

                   QUIT

               WRITE !,PSD,?32,+PSD(PSD),?42,$PIECE(PSD(PSD),U,2)

 +2        QUIT

HL         NEW HLERR,HLEVN,HLNDAP,HLMTN,HLFS,HLECH,HLSDATA,HLSDT,HLSEC,HLCHAR,HLDA,HLDAN,HLDAP,HLDT,HLDT1,HLNDAP0,HLPID,HLQ,HLVER

 +1        SET HLNDAP="PSD-NDES"

           DO INIT^HLTRANS

           IF $DATA(HLERR)

               DO KILL^HLTRANS

               QUIT

 +2        SET HLMTN="MFN"

           SET HLEVN=1

           SET HLSDT=DT

MFI        SET ^TMP("HLS",$JOB,HLSDT,1)="MFI"_HLFS_200_$EXTRACT(HLECH)_"NEW PERSON"_HLFS_"PSD-CS"_HLFS_"UPD"_HLFS_HLDT1_HLFS_HLFS_"AL"

           SET PSD=0

           SET PSD(1)=2

MFE        FOR

               SET PSD=$ORDER(PSD(PSD))

               IF PSD']""

                   QUIT

               SET ^TMP("HLS",$JOB,HLSDT,PSD(1))="MFE"_HLFS_"MUP"_HLFS_HLFS_HLFS_PSD(PSD)_$EXTRACT(HLECH)_PSD

               SET PSD(1)=PSD(1)+1

SEND       DO EN^HLTRANS

           QUIT

HEADER     IF $EXTRACT(IOST,1,2)'="P-"

               IF PG

                   SET DIR(0)="E"

                   DO ^DIR

                   KILL DIR

                   IF 'Y

                       SET PSDOUT=1

                       QUIT

 +1        IF $$S^%ZTLOAD

               WRITE !!,"Task#",$GET(ZTSK),", ",$GET(ZTDESC)," was stopped by ",$PIECE($GET(^VA(200,+$GET(DUZ),0)),U),"."

               SET PSDOUT=1

 +2        IF $Y

               WRITE @IOF

           SET $PIECE(LN,"-",81)=""

           SET PG=PG+1

 +3        WRITE !,"User List for Narcotic Dispensing Equipment System",?70

 +4        WRITE "Page:  ",PG,!,LN,!?5,"NAME",?32,"USER ID",?42,"PHONE NUMBER",!,LN

PSDUSER.m