Routine: PSDGPR

PSDGPR ;BIR/CML,JPW-Print NAOU Inventory Group List ; 2 Aug 94

 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97

 I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)

 D NOW^%DTC S PSDT=$P(%,".")

 W !!!,"This report shows data stored for NAOU Inventory Groups.",!!,"Right margin for this report is 80 columns.",!,"You may queue the report to print at a later time.",!!

 I '$O(^PSI(58.2,0)) W !,"You MUST create Inventory Groups before running this report!" K %,%I,%H Q

DEV K %ZIS,IOP S %ZIS="QM",%ZIS("B")="" D ^%ZIS I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED!" G QUIT

 I $D(IO("Q")) K IO("Q") S PSDIO=ION,ZTIO="" K ZTSAVE,ZTDTH,ZTSK S ZTRTN="ENQ^PSDGPR",ZTDESC="Compile Data for NAOU Inventory Groups",ZTSAVE("PSDIO")="",ZTSAVE("PSDT")="",ZTSAVE("PSDSITE")=""

 I  D ^%ZTLOAD K ZTSK G QUIT

 U IO

ENQ ;ENTRY POINT WHEN QUEUED

INVG K ^TMP("PSDGPR",$J) F INVG=0:0 S INVG=$O(^PSI(58.2,INVG)) G:('INVG)&($D(ZTQUEUED)) PRTQUE G:'INVG PRINT D BUILD

BUILD ;BUILD DATA ELEMENTS

 I $S('$D(^PSI(58.2,INVG,0)):1,^(0)="":1,'$O(^(0)):1,1:0) S DIK="^PSI(58.2,",DA=INVG D ^DIK K DIK Q

 F NAOU=0:0 S NAOU=$O(^PSI(58.2,INVG,3,NAOU)) Q:'NAOU  I $D(^(NAOU,0)) F TYPE=0:0 S TYPE=$O(^PSI(58.2,INVG,3,NAOU,1,TYPE)) Q:'TYPE  I $D(^(TYPE,0)) D SETGL

SETGL ;

 Q:$P($G(^PSD(58.8,NAOU,0)),"^",3)'=+PSDSITE

 S ANM=$S($D(^PSD(58.8,NAOU,0)):$P(^(0),"^"),1:"NAOU NAME MISSING"),TYPENM=$S($D(^PSI(58.16,TYPE,0)):$P(^(0),"^"),1:"TYPE NAME MISSING"),GNM=^PSI(58.2,INVG,0),INACT=""

 I $D(^PSD(58.8,NAOU,"I")),^("I")]"",^("I")'>DT S INACT="I"

 S ^TMP("PSDGPR",$J,GNM,ANM_"^"_INACT,TYPENM)=""

PRTQUE ;AFTER DATA IS COMPILED, QUEUE THE PRINT

 K ZTSAVE,ZTIO S ZTIO=PSDIO,ZTRTN="PRINT^PSDGPR",ZTDESC="Print Data for Inventory Group List",ZTDTH=$H,ZTSAVE("^TMP(""PSDGPR"",$J,")=""

 D ^%ZTLOAD K ^TMP("PSDGPR",$J) G QUIT

PRINT ;

 K LN S $P(LN,"-",80)="",(PG,PSDOUT)=0,%DT="",(GNM,ANM,TYPENM)="",X="T" D ^%DT X ^DD("DD") S HDT=Y D HDR

 I '$D(^TMP("PSDGPR",$J)) W !?17,"***** NO DATA AVAILABLE FOR THIS REPORT *****" G QUIT

 F LL=0:0 S GNM=$O(^TMP("PSDGPR",$J,GNM)) Q:GNM=""!(PSDOUT)  D:$Y+4>IOSL PAGE Q:PSDOUT  W !!,"=> ",GNM F LL=0:0 S ANM=$O(^TMP("PSDGPR",$J,GNM,ANM)) Q:ANM=""!(PSDOUT)  D:$Y+4>IOSL PAGE Q:PSDOUT  W !?13,$P(ANM,"^") D WRTDATA Q:PSDOUT

DONE I $E(IOST)'="C" W @IOF

 I $E(IOST,1,2)="C-",'PSDOUT W ! K DIR,DIRUT S DIR(0)="EA",DIR("A")="END OF REPORT!  Press <RET> to return to the menu" D ^DIR K DIR

QUIT ;

 K %DT,DTOUT,NAOU,ANM,HDT,INACT,INVG,GNM,LL,LN,PG,PSDT,TYPE,TYPENM,X,Y,PSDIO,ZTSK,ZTDESC,ZTRTN,ZTIO,DA,IO("Q"),%,%I,%H,ANS,PSDOUT,POP

 K ^TMP("PSDGPR",$J) D ^%ZISC

 S:$D(ZTQUEUED) ZTREQ="@" Q

WRTDATA ;DATA LINES

 I $P(ANM,"^",2)="I" W "          *** INACTIVE ***"

 F LL=0:0 S TYPENM=$O(^TMP("PSDGPR",$J,GNM,ANM,TYPENM)) Q:TYPENM=""!(PSDOUT)  D:$Y+4>IOSL PAGE Q:PSDOUT  W !?18,TYPENM

HDR ;HEADER

 W:$Y @IOF S PG=PG+1 W !?28,"NAOU INVENTORY GROUP LIST",?71,"PAGE: ",PG,!?31,"PRINTED: ",HDT,!!,"=> INVENTORY GROUP",!?13,"NARCOTIC AREA OF USE",!?18,"TYPE",!,LN

PAGE ;end of page check

 I $E(IOST,1,2)="C-" W ! K DA,DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSDOUT=1 Q

 D HDR

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDGPR   3102     printed  Mar 13, 2025@20:50:49                                                                                                                                                                                                      Page 2

PSDGPR    ;BIR/CML,JPW-Print NAOU Inventory Group List ; 2 Aug 94

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

 +2        IF '$DATA(PSDSITE)

               DO ^PSDSET

               if '$DATA(PSDSITE)

                   QUIT

 +3        DO NOW^%DTC

           SET PSDT=$PIECE(%,".")

 +4        WRITE !!!,"This report shows data stored for NAOU Inventory Groups.",!!,"Right margin for this report is 80 columns.",!,"You may queue the report to print at a later time.",!!

 +5        IF '$ORDER(^PSI(58.2,0))

               WRITE !,"You MUST create Inventory Groups before running this report!"

               KILL %,%I,%H

               QUIT

DEV        KILL %ZIS,IOP

           SET %ZIS="QM"

           SET %ZIS("B")=""

           DO ^%ZIS

           IF POP

               WRITE !,"NO DEVICE SELECTED OR REPORT PRINTED!"

               GOTO QUIT

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

               KILL IO("Q")

               SET PSDIO=ION

               SET ZTIO=""

               KILL ZTSAVE,ZTDTH,ZTSK

               SET ZTRTN="ENQ^PSDGPR"

               SET ZTDESC="Compile Data for NAOU Inventory Groups"

               SET ZTSAVE("PSDIO")=""

               SET ZTSAVE("PSDT")=""

               SET ZTSAVE("PSDSITE")=""

 +2       IF $TEST

               DO ^%ZTLOAD

               KILL ZTSK

               GOTO QUIT

 +3        USE IO

 +4       ;

ENQ       ;ENTRY POINT WHEN QUEUED

INVG       KILL ^TMP("PSDGPR",$JOB)

           FOR INVG=0:0

               SET INVG=$ORDER(^PSI(58.2,INVG))

               if ('INVG)&($DATA(ZTQUEUED))

                   GOTO PRTQUE

               if 'INVG

                   GOTO PRINT

               DO BUILD

 +1       ;

BUILD     ;BUILD DATA ELEMENTS

 +1        IF $SELECT('$DATA(^PSI(58.2,INVG,0)):1,^(0)="":1,'$ORDER(^(0)):1,1:0)

               SET DIK="^PSI(58.2,"

               SET DA=INVG

               DO ^DIK

               KILL DIK

               QUIT

 +2        FOR NAOU=0:0

               SET NAOU=$ORDER(^PSI(58.2,INVG,3,NAOU))

               if 'NAOU

                   QUIT

               IF $DATA(^(NAOU,0))

                   FOR TYPE=0:0

                       SET TYPE=$ORDER(^PSI(58.2,INVG,3,NAOU,1,TYPE))

                       if 'TYPE

                           QUIT

                       IF $DATA(^(TYPE,0))

                           DO SETGL

 +3        QUIT

SETGL     ;

 +1        if $PIECE($GET(^PSD(58.8,NAOU,0)),"^",3)'=+PSDSITE

               QUIT

 +2        SET ANM=$SELECT($DATA(^PSD(58.8,NAOU,0)):$PIECE(^(0),"^"),1:"NAOU NAME MISSING")

           SET TYPENM=$SELECT($DATA(^PSI(58.16,TYPE,0)):$PIECE(^(0),"^"),1:"TYPE NAME MISSING")

           SET GNM=^PSI(58.2,INVG,0)

           SET INACT=""

 +3        IF $DATA(^PSD(58.8,NAOU,"I"))

               IF ^("I")]""

                   IF ^("I")'>DT

                       SET INACT="I"

 +4        SET ^TMP("PSDGPR",$JOB,GNM,ANM_"^"_INACT,TYPENM)=""

 +5        QUIT

 +6       ;

PRTQUE    ;AFTER DATA IS COMPILED, QUEUE THE PRINT

 +1        KILL ZTSAVE,ZTIO

           SET ZTIO=PSDIO

           SET ZTRTN="PRINT^PSDGPR"

           SET ZTDESC="Print Data for Inventory Group List"

           SET ZTDTH=$HOROLOG

           SET ZTSAVE("^TMP(""PSDGPR"",$J,")=""

 +2        DO ^%ZTLOAD

           KILL ^TMP("PSDGPR",$JOB)

           GOTO QUIT

PRINT     ;

 +1        KILL LN

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

           SET (PG,PSDOUT)=0

           SET %DT=""

           SET (GNM,ANM,TYPENM)=""

           SET X="T"

           DO ^%DT

           XECUTE ^DD("DD")

           SET HDT=Y

           DO HDR

 +2        IF '$DATA(^TMP("PSDGPR",$JOB))

               WRITE !?17,"***** NO DATA AVAILABLE FOR THIS REPORT *****"

               GOTO QUIT

 +3        FOR LL=0:0

               SET GNM=$ORDER(^TMP("PSDGPR",$JOB,GNM))

               if GNM=""!(PSDOUT)

                   QUIT

               if $Y+4>IOSL

                   DO PAGE

               if PSDOUT

                   QUIT

               WRITE !!,"=> ",GNM

               FOR LL=0:0

                   SET ANM=$ORDER(^TMP("PSDGPR",$JOB,GNM,ANM))

                   if ANM=""!(PSDOUT)

                       QUIT

                   if $Y+4>IOSL

                       DO PAGE

                   if PSDOUT

                       QUIT

                   WRITE !?13,$PIECE(ANM,"^")

                   DO WRTDATA

                   if PSDOUT

                       QUIT

DONE       IF $EXTRACT(IOST)'="C"

               WRITE @IOF

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

               IF 'PSDOUT

                   WRITE !

                   KILL DIR,DIRUT

                   SET DIR(0)="EA"

                   SET DIR("A")="END OF REPORT!  Press <RET> to return to the menu"

                   DO ^DIR

                   KILL DIR

QUIT      ;

 +1        KILL %DT,DTOUT,NAOU,ANM,HDT,INACT,INVG,GNM,LL,LN,PG,PSDT,TYPE,TYPENM,X,Y,PSDIO,ZTSK,ZTDESC,ZTRTN,ZTIO,DA,IO("Q"),%,%I,%H,ANS,PSDOUT,POP

 +2        KILL ^TMP("PSDGPR",$JOB)

           DO ^%ZISC

 +3        if $DATA(ZTQUEUED)

               SET ZTREQ="@"

           QUIT

WRTDATA   ;DATA LINES

 +1        IF $PIECE(ANM,"^",2)="I"

               WRITE "          *** INACTIVE ***"

 +2        FOR LL=0:0

               SET TYPENM=$ORDER(^TMP("PSDGPR",$JOB,GNM,ANM,TYPENM))

               if TYPENM=""!(PSDOUT)

                   QUIT

               if $Y+4>IOSL

                   DO PAGE

               if PSDOUT

                   QUIT

               WRITE !?18,TYPENM

 +3        QUIT

HDR       ;HEADER

 +1        if $Y

               WRITE @IOF

           SET PG=PG+1

           WRITE !?28,"NAOU INVENTORY GROUP LIST",?71,"PAGE: ",PG,!?31,"PRINTED: ",HDT,!!,"=> INVENTORY GROUP",!?13,"NARCOTIC AREA OF USE",!?18,"TYPE",!,LN

 +2        QUIT

PAGE      ;end of page check

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

               WRITE !

               KILL DA,DIR

               SET DIR(0)="E"

               DO ^DIR

               KILL DIR

               IF 'Y

                   SET PSDOUT=1

                   QUIT

 +2        DO HDR

 +3        QUIT

PSDGPR.m