- 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 Jan 18, 2025@02:42:50 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