DVBAPEND ;ALB/GTS-557/THM-PENDING REPORT ; 7/6/90 1:18 PM
;;2.7;AMIE;**17**;Apr 10, 1995
;
D NOPARM^DVBAUTL2 G:$D(DVBAQUIT) KILL^DVBAUTIL
TERM D HOME^%ZIS W @IOF,!,"Pending 7131 Report",!!! K NOASK,^TMP($J)
S DVBADD=^DD("DD"),(RONUM,Y)=0 D SORT^DVBAUTIL G:Y<0 KILL
D SORTDIV^DVBAPND1 G:Y<0 KILL S %ZIS="Q" D ^%ZIS K %ZIS G:POP KILL
;
QUEUE I $D(IO("Q")) S ZTRTN="SETUP^DVBAPEND",ZTIO=ION,ZTDESC="AMIE PENDING REPORT",NOASK=1 F I="DIVNAM","SELDIV","DVBADD","RONUM","RO","NOASK","Y","DIVNUM" S ZTSAVE(I)=""
I $D(IO("Q")) D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued.",!! H 1 G KILL
;
SETUP D STM^DVBCUTL4
S FDT(0)=$$FMTE^XLFDT(DT,"5DZ"),(PG,DVBAQUIT)=0
S HEAD="PENDING REQUEST REPORT FOR "_$P(^DVB(396.1,1,0),U,1)
S HEAD2=$S(RO="Y":"FOR REGIONAL OFFICE "_RONUM,1:"ALL REGIONAL OFFICES")
S HEAD2=HEAD2_$S(SELDIV="Y":", FOR DIVISION "_DIVNAM,1:", ALL DIVISIONS")
S PROCDT="Processed on: "_FDT(0)
S QQ=1,NODTA=0 U IO D HEADER^DVBAPND1
DATA N REQDTE S REQDTE=""
S:SELDIV="Y" ADIV=DIVNAM
F J=0:0 S REQDTE=$O(^DVB(396,"E",REQDTE)) Q:REQDTE="" F DA=0:0 S DA=$O(^DVB(396,"E",REQDTE,DA)) Q:DA="" I $D(^DVB(396,DA,1)),($P(^DVB(396,DA,1),U,12)="") D:SELDIV="N" ADIV D MAKUTL
S (ADIV,REQDTE)=""
F L=0:0 S REQDTE=$O(^TMP($J,REQDTE)) Q:REQDTE="" D LVL2LP
;
EXIT I NODTA=0 U IO W *7,"No pending requests found for parameters entered.",!!
;
KILL S XRTN=$T(+0)
D SPM^DVBCUTL4
K ^TMP("DVBA","ADMIT",$J),^TMP($J),DVBAQUIT,SELDIV,DIVNUM,REQDTE
K LPCNT1,PATDA,DIVNAM,XJ,XI,GDIVPTR,GDIVNUM,GINSTPT,GDIVNAM,GDIV
D:$D(ZTQUEUED) KILL^%ZTLOAD G KILL^DVBAUTIL
Q
;
LVL2LP ; ** 2nd level of the 2nd loop in the DATA tag - search ADIV **
F J=0:0 S ADIV=$O(^TMP($J,REQDTE,ADIV)) Q:ADIV="" D LPLVL3
Q
;
LPLVL3 ; ** 2nd level of the loop in the LVL2LP tag - search DA **
F DA=0:0 S DA=$O(^TMP($J,REQDTE,ADIV,DA)) Q:DA="" D PRINT^DVBAPND1 S:DVBAQUIT=1 ADIV="ZZZZ",DA=999999999,REQDTE=9999999 S QQ=1
Q
;
MAKUTL ; ** Sort on Request Date to set up a temporary utility global **
S REQDTE=$P(^DVB(396,DA,1),"^",1),PATDA=$P(^DVB(396,DA,0),"^",1)
S CFLOC=$$STATION^DVBAUTL1(PATDA)
S:CFLOC=-1 CFLOC=0
I SELDIV="Y"&(RO="Y") I CFLOC=RONUM D CHKDIV D:$D(DVBAFND) SETARY
I SELDIV="Y"&(RO="N") D CHKDIV D:$D(DVBAFND) SETARY
I SELDIV="N"&(RO="Y") I CFLOC=RONUM D SETARY
I SELDIV="N"&(RO="N") D SETARY
K DVBAFND
QUIT
;
SETARY ; ** Set temporary utility global **
S ^TMP($J,REQDTE,ADIV,DA)=""
QUIT
;
ADIV S ADIV=$S($D(^DVB(396,DA,2)):$P(^(2),U,9),1:"") S ADIV=$S($D(^DG(40.8,+ADIV,0)):$P(^(0),U,1),1:"Unknown Division")
Q
;
CHKDIV ;**Check for selected Div
N FLDVAR
I $D(^DVB(396,DA,6)) DO
.F FLDVAR=7,9,11,13,15,17,19,21,23,26,28 Q:$D(DVBAFND) DO
..I ($P(^DVB(396,DA,6),U,FLDVAR)=DIVNUM) DO
...I FLDVAR=7 S:$P(^DVB(396,DA,1),U,FLDVAR)="P" DVBAFND=""
...I FLDVAR'=7 S:$P(^DVB(396,DA,0),U,FLDVAR)="P" DVBAFND=""
I $D(^DVB(396,DA,2)),('$D(DVBAFND)) DO ;**Check Routing Loc Division
.I $D(^DVB(396,DA,1)) DO
..I $P(^DVB(396,DA,2),U,9)=DIVNUM,($P(^DVB(396,DA,1),U,12)="") DO
...S DVBAFND=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAPEND 3080 printed Nov 22, 2024@16:51:49 Page 2
DVBAPEND ;ALB/GTS-557/THM-PENDING REPORT ; 7/6/90 1:18 PM
+1 ;;2.7;AMIE;**17**;Apr 10, 1995
+2 ;
+3 DO NOPARM^DVBAUTL2
if $DATA(DVBAQUIT)
GOTO KILL^DVBAUTIL
TERM DO HOME^%ZIS
WRITE @IOF,!,"Pending 7131 Report",!!!
KILL NOASK,^TMP($JOB)
+1 SET DVBADD=^DD("DD")
SET (RONUM,Y)=0
DO SORT^DVBAUTIL
if Y<0
GOTO KILL
+2 DO SORTDIV^DVBAPND1
if Y<0
GOTO KILL
SET %ZIS="Q"
DO ^%ZIS
KILL %ZIS
if POP
GOTO KILL
+3 ;
QUEUE IF $DATA(IO("Q"))
SET ZTRTN="SETUP^DVBAPEND"
SET ZTIO=ION
SET ZTDESC="AMIE PENDING REPORT"
SET NOASK=1
FOR I="DIVNAM","SELDIV","DVBADD","RONUM","RO","NOASK","Y","DIVNUM"
SET ZTSAVE(I)=""
+1 IF $DATA(IO("Q"))
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !!,"Request queued.",!!
HANG 1
GOTO KILL
+2 ;
SETUP DO STM^DVBCUTL4
+1 SET FDT(0)=$$FMTE^XLFDT(DT,"5DZ")
SET (PG,DVBAQUIT)=0
+2 SET HEAD="PENDING REQUEST REPORT FOR "_$PIECE(^DVB(396.1,1,0),U,1)
+3 SET HEAD2=$SELECT(RO="Y":"FOR REGIONAL OFFICE "_RONUM,1:"ALL REGIONAL OFFICES")
+4 SET HEAD2=HEAD2_$SELECT(SELDIV="Y":", FOR DIVISION "_DIVNAM,1:", ALL DIVISIONS")
+5 SET PROCDT="Processed on: "_FDT(0)
+6 SET QQ=1
SET NODTA=0
USE IO
DO HEADER^DVBAPND1
DATA NEW REQDTE
SET REQDTE=""
+1 if SELDIV="Y"
SET ADIV=DIVNAM
+2 FOR J=0:0
SET REQDTE=$ORDER(^DVB(396,"E",REQDTE))
if REQDTE=""
QUIT
FOR DA=0:0
SET DA=$ORDER(^DVB(396,"E",REQDTE,DA))
if DA=""
QUIT
IF $DATA(^DVB(396,DA,1))
IF ($PIECE(^DVB(396,DA,1),U,12)="")
if SELDIV="N"
DO ADIV
DO MAKUTL
+3 SET (ADIV,REQDTE)=""
+4 FOR L=0:0
SET REQDTE=$ORDER(^TMP($JOB,REQDTE))
if REQDTE=""
QUIT
DO LVL2LP
+5 ;
EXIT IF NODTA=0
USE IO
WRITE *7,"No pending requests found for parameters entered.",!!
+1 ;
KILL SET XRTN=$TEXT(+0)
+1 DO SPM^DVBCUTL4
+2 KILL ^TMP("DVBA","ADMIT",$JOB),^TMP($JOB),DVBAQUIT,SELDIV,DIVNUM,REQDTE
+3 KILL LPCNT1,PATDA,DIVNAM,XJ,XI,GDIVPTR,GDIVNUM,GINSTPT,GDIVNAM,GDIV
+4 if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
GOTO KILL^DVBAUTIL
+5 QUIT
+6 ;
LVL2LP ; ** 2nd level of the 2nd loop in the DATA tag - search ADIV **
+1 FOR J=0:0
SET ADIV=$ORDER(^TMP($JOB,REQDTE,ADIV))
if ADIV=""
QUIT
DO LPLVL3
+2 QUIT
+3 ;
LPLVL3 ; ** 2nd level of the loop in the LVL2LP tag - search DA **
+1 FOR DA=0:0
SET DA=$ORDER(^TMP($JOB,REQDTE,ADIV,DA))
if DA=""
QUIT
DO PRINT^DVBAPND1
if DVBAQUIT=1
SET ADIV="ZZZZ"
SET DA=999999999
SET REQDTE=9999999
SET QQ=1
+2 QUIT
+3 ;
MAKUTL ; ** Sort on Request Date to set up a temporary utility global **
+1 SET REQDTE=$PIECE(^DVB(396,DA,1),"^",1)
SET PATDA=$PIECE(^DVB(396,DA,0),"^",1)
+2 SET CFLOC=$$STATION^DVBAUTL1(PATDA)
+3 if CFLOC=-1
SET CFLOC=0
+4 IF SELDIV="Y"&(RO="Y")
IF CFLOC=RONUM
DO CHKDIV
if $DATA(DVBAFND)
DO SETARY
+5 IF SELDIV="Y"&(RO="N")
DO CHKDIV
if $DATA(DVBAFND)
DO SETARY
+6 IF SELDIV="N"&(RO="Y")
IF CFLOC=RONUM
DO SETARY
+7 IF SELDIV="N"&(RO="N")
DO SETARY
+8 KILL DVBAFND
+9 QUIT
+10 ;
SETARY ; ** Set temporary utility global **
+1 SET ^TMP($JOB,REQDTE,ADIV,DA)=""
+2 QUIT
+3 ;
ADIV SET ADIV=$SELECT($DATA(^DVB(396,DA,2)):$PIECE(^(2),U,9),1:"")
SET ADIV=$SELECT($DATA(^DG(40.8,+ADIV,0)):$PIECE(^(0),U,1),1:"Unknown Division")
+1 QUIT
+2 ;
CHKDIV ;**Check for selected Div
+1 NEW FLDVAR
+2 IF $DATA(^DVB(396,DA,6))
Begin DoDot:1
+3 FOR FLDVAR=7,9,11,13,15,17,19,21,23,26,28
if $DATA(DVBAFND)
QUIT
Begin DoDot:2
+4 IF ($PIECE(^DVB(396,DA,6),U,FLDVAR)=DIVNUM)
Begin DoDot:3
+5 IF FLDVAR=7
if $PIECE(^DVB(396,DA,1),U,FLDVAR)="P"
SET DVBAFND=""
+6 IF FLDVAR'=7
if $PIECE(^DVB(396,DA,0),U,FLDVAR)="P"
SET DVBAFND=""
End DoDot:3
End DoDot:2
End DoDot:1
+7 ;**Check Routing Loc Division
IF $DATA(^DVB(396,DA,2))
IF ('$DATA(DVBAFND))
Begin DoDot:1
+8 IF $DATA(^DVB(396,DA,1))
Begin DoDot:2
+9 IF $PIECE(^DVB(396,DA,2),U,9)=DIVNUM
IF ($PIECE(^DVB(396,DA,1),U,12)="")
Begin DoDot:3
+10 SET DVBAFND=""
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT
