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)
Q
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
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDUSER 2000 printed Nov 22, 2024@16:59:26 Page 2
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
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
