Routine: PRCFUOM

PRCFUOM ;WISC/SJG/PL-850 UNDELIVERED ORDERS RECONCILIATION ; 11/6/97  1510

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

BEG ;

 S DIR(0)="Y",DIR("A")="Are you sure that you want to manually run this option"

 S DIR("A",1)=" ",DIR("A",2)="This option generates the 850 Undelivered Orders Reconciliation Report."

 S DIR("A",3)="This report is very resource intensive and should be scheduled to run"

 S DIR("A",4)="in off-hours.",DIR("A",5)=" "

 S DIR("A",6)="This report is restricted to purchase orders from a single station, and"

 S DIR("A",7)="can be limited to a date range.  The default date range is from T-90 days",DIR("A",8)="to T.",DIR("A",9)=" "

 S DIR("T")=120,DIR("B")="NO" D ^DIR K DIR G:'Y!($D(DIRUT)) EXIT

SITE S PRCF("X")="AS" D ^PRCFSITE G:'% EXIT S PRCFSITE=PRC("SITE") W !

DATE K PRCFBEG,PRCFBEGX,PRCFEND,PRCFENDX

 S X="T-90" D ^%DT S PRCFBEG=Y,PRCFBEGZ=Y D DD^%DT S PRCFBEGX=Y

 S X="T" D ^%DT S PRCFEND=Y D DD^%DT S PRCFENDX=Y

 S %DT="AE",%DT("A")="Select BEGINNING DATE: ",%DT("B")=PRCFBEGX D ^%DT K %DT G:Y<1 EXIT

 I Y>PRCFEND W !!,$C(7),"Beginning date can't be greater than Today's date.  Please reenter !",! G DATE

 I Y'=PRCFBEG S PRCFBEG=Y,PRCFBEGZ=Y D DD^%DT S PRCFBEGX=Y

 W ! S %DT="AE",%DT("A")="Select ENDING DATE: ",%DT("B")=PRCFENDX D ^%DT K %DT G:Y<1 EXIT

 I Y<PRCFBEGZ W !!,$C(7),"Ending date can't be less than Beginning date. Please reenter !",! G DATE

 I Y>PRCFEND W !!,$C(7),"Ending date can't be greater than Today's date. Please reenter !",! G DATE

 I Y'=PRCFEND S PRCFEND=Y D DD^%DT S PRCFENDX=Y

RPT D DEV G:POP EXIT I '$D(IO("Q")) D WAIT^DICD

 I $D(IO("Q")) S ZTDTH="",ZTDESC="Running 850 Undelivered Orders Reconciliation Report",ZTRTN="DQ^PRCFUOM",ZTSAVE("PRC*")="" D ^%ZTLOAD,^%ZISC,AGN G EXIT:%'=1 W !! G SITE

 D DQ,^%ZISC,AGN G EXIT:%'=1 W !! G SITE

DQ ;

 S (PRCFAT,PRCFCT,PRCFOT,PRCFCS,PRCFOS,PRCFAS)=0,L=0

 S DIC="^PRC(442,",FLDS="[PRCFUO]",BY="[PRCFUO MAN]" S:$D(ION) IOP=ION

 S FR=",,"_PRCFBEG,TO=",,"_PRCFEND,DIOEND="D B^PRCFUO"

 S PRCFI=";30;31;33;37;38;40;41;45;48;49;",PRCFMOP=";1;8;"

 S DIS(0)="I $D(^PRC(442,D0,0)),$O(^PRC(442,D0,22,0))>0 I $P(^PRC(442,D0,0),U,17)'=$P(^(0),U,16) I +$P(^(0),U,1)=PRCFSITE I $G(^PRC(442,D0,7)),PRCFI'[("";""_$P($G(^PRC(442,D0,7)),""^"",2)_"";"")"

 S DIS(1)="I $D(^PRC(442,D0,0)),$P(^(0),U,2),PRCFMOP[("";""_$P(^(0),U,2)_"";"") D C^PRCFUO I PRCFU>.01"

 S DHD="850 UNDELIVERED ORDERS RECONCILIATION FOR STATION "_PRCFSITE_" FROM "_PRCFBEGX_" TO "_PRCFENDX

 D EN1^DIP,EXIT

EXIT ;

 KILL %,%DT,%ZIS,BY,DHD,DIC,DIOEND,DIR,DIRUT,DIS,FLDS,FR,L,PRC

 KILL PRCF,PRCFAS,PRCFAT,PRCFBEG,PRCFBEGX,PRCFBEGZ,PRCFCS,PRCFCT,PRCFEND,PRCFENDX

 KILL PRCFI,PRCFMOP,PRCFOS,PRCFOT,PRCFSITE,TO,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE

 QUIT

DEV W ! K IO("Q") S %ZIS("B")="HOME",%ZIS="QM" D ^%ZIS Q

AGN W !!,"Would you like to run another reconciliation report" S %=2 D YN^DICN G AGN:%=0 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFUOM   2938     printed  Apr 23, 2025@18:18:58                                                                                                                                                                                                     Page 2

PRCFUOM   ;WISC/SJG/PL-850 UNDELIVERED ORDERS RECONCILIATION ; 11/6/97  1510

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

BEG       ;

 +1        SET DIR(0)="Y"

           SET DIR("A")="Are you sure that you want to manually run this option"

 +2        SET DIR("A",1)=" "

           SET DIR("A",2)="This option generates the 850 Undelivered Orders Reconciliation Report."

 +3        SET DIR("A",3)="This report is very resource intensive and should be scheduled to run"

 +4        SET DIR("A",4)="in off-hours."

           SET DIR("A",5)=" "

 +5        SET DIR("A",6)="This report is restricted to purchase orders from a single station, and"

 +6        SET DIR("A",7)="can be limited to a date range.  The default date range is from T-90 days"

           SET DIR("A",8)="to T."

           SET DIR("A",9)=" "

 +7        SET DIR("T")=120

           SET DIR("B")="NO"

           DO ^DIR

           KILL DIR

           if 'Y!($DATA(DIRUT))

               GOTO EXIT

SITE       SET PRCF("X")="AS"

           DO ^PRCFSITE

           if '%

               GOTO EXIT

           SET PRCFSITE=PRC("SITE")

           WRITE !

DATE       KILL PRCFBEG,PRCFBEGX,PRCFEND,PRCFENDX

 +1        SET X="T-90"

           DO ^%DT

           SET PRCFBEG=Y

           SET PRCFBEGZ=Y

           DO DD^%DT

           SET PRCFBEGX=Y

 +2        SET X="T"

           DO ^%DT

           SET PRCFEND=Y

           DO DD^%DT

           SET PRCFENDX=Y

 +3        SET %DT="AE"

           SET %DT("A")="Select BEGINNING DATE: "

           SET %DT("B")=PRCFBEGX

           DO ^%DT

           KILL %DT

           if Y<1

               GOTO EXIT

 +4        IF Y>PRCFEND

               WRITE !!,$CHAR(7),"Beginning date can't be greater than Today's date.  Please reenter !",!

               GOTO DATE

 +5        IF Y'=PRCFBEG

               SET PRCFBEG=Y

               SET PRCFBEGZ=Y

               DO DD^%DT

               SET PRCFBEGX=Y

 +6        WRITE !

           SET %DT="AE"

           SET %DT("A")="Select ENDING DATE: "

           SET %DT("B")=PRCFENDX

           DO ^%DT

           KILL %DT

           if Y<1

               GOTO EXIT

 +7        IF Y<PRCFBEGZ

               WRITE !!,$CHAR(7),"Ending date can't be less than Beginning date. Please reenter !",!

               GOTO DATE

 +8        IF Y>PRCFEND

               WRITE !!,$CHAR(7),"Ending date can't be greater than Today's date. Please reenter !",!

               GOTO DATE

 +9        IF Y'=PRCFEND

               SET PRCFEND=Y

               DO DD^%DT

               SET PRCFENDX=Y

RPT        DO DEV

           if POP

               GOTO EXIT

           IF '$DATA(IO("Q"))

               DO WAIT^DICD

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

               SET ZTDTH=""

               SET ZTDESC="Running 850 Undelivered Orders Reconciliation Report"

               SET ZTRTN="DQ^PRCFUOM"

               SET ZTSAVE("PRC*")=""

               DO ^%ZTLOAD

               DO ^%ZISC

               DO AGN

               if %'=1

                   GOTO EXIT

               WRITE !!

               GOTO SITE

 +2        DO DQ

           DO ^%ZISC

           DO AGN

           if %'=1

               GOTO EXIT

           WRITE !!

           GOTO SITE

DQ        ;

 +1        SET (PRCFAT,PRCFCT,PRCFOT,PRCFCS,PRCFOS,PRCFAS)=0

           SET L=0

 +2        SET DIC="^PRC(442,"

           SET FLDS="[PRCFUO]"

           SET BY="[PRCFUO MAN]"

           if $DATA(ION)

               SET IOP=ION

 +3        SET FR=",,"_PRCFBEG

           SET TO=",,"_PRCFEND

           SET DIOEND="D B^PRCFUO"

 +4        SET PRCFI=";30;31;33;37;38;40;41;45;48;49;"

           SET PRCFMOP=";1;8;"

 +5        SET DIS(0)="I $D(^PRC(442,D0,0)),$O(^PRC(442,D0,22,0))>0 I $P(^PRC(442,D0,0),U,17)'=$P(^(0),U,16) I +$P(^(0),U,1)=PRCFSITE I $G(^PRC(442,D0,7)),PRCFI'[("";""_$P($G(^PRC(442,D0,7)),""^"",2)_"";"")"

 +6        SET DIS(1)="I $D(^PRC(442,D0,0)),$P(^(0),U,2),PRCFMOP[("";""_$P(^(0),U,2)_"";"") D C^PRCFUO I PRCFU>.01"

 +7        SET DHD="850 UNDELIVERED ORDERS RECONCILIATION FOR STATION "_PRCFSITE_" FROM "_PRCFBEGX_" TO "_PRCFENDX

 +8        DO EN1^DIP

           DO EXIT

 +9        QUIT

EXIT      ;

 +1        KILL %,%DT,%ZIS,BY,DHD,DIC,DIOEND,DIR,DIRUT,DIS,FLDS,FR,L,PRC

 +2        KILL PRCF,PRCFAS,PRCFAT,PRCFBEG,PRCFBEGX,PRCFBEGZ,PRCFCS,PRCFCT,PRCFEND,PRCFENDX

 +3        KILL PRCFI,PRCFMOP,PRCFOS,PRCFOT,PRCFSITE,TO,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE

 +4        QUIT

DEV        WRITE !

           KILL IO("Q")

           SET %ZIS("B")="HOME"

           SET %ZIS="QM"

           DO ^%ZIS

           QUIT

AGN        WRITE !!,"Would you like to run another reconciliation report"

           SET %=2

           DO YN^DICN

           if %=0

               GOTO AGN

           QUIT

PRCFUOM.m