Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ASURQ81P

ASURQ81P.m

Go to the documentation of this file. 
  1. ASURQ81P ; IHS/ITSC/LMH -RPT 81 LIST DROP SHIP ITEMS ; 
  1.  ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
  1.  ;This routine formats and prints report 81, List of Drop Ship
  1.  ;Items.
  1. EN ;EP;PRIMARY ENTRY POINT FOR REPORT 81
  1.  Q  ;WAR 5/21/99
  1.  I '$D(IO) D HOME^%ZIS
  1.  I '$D(DUZ(2)) W !,"Report must be run from Kernel option" Q
  1.  I '$D(ASUL(1,"AR","AP")) D SETAREA^ASULARST
  1.  S ASUK("PTRSEL")=$G(ASUK("PTRSEL")) I ASUK("PTRSEL")]"" G PSER
  1.  S ZTRTN="PSER^ASURQ81P",ZTDESC="SAMS RPT 81" D O^ASUUZIS
  1.  I POP S IOP=$I D ^%ZIS Q
  1.  I ASUK(ASUK("PTR"),"Q") Q
  1. PSER ;EP;FOR TASKMAN QUEUE OF PRINT
  1.  S ASUF("HDR")=1
  1.  S ASUX("ARST")=$O(^XTMP("ASUR","R81",0))
  1.  I ASUX("ARST")']"" D
  1.  .I ASUP("TYP")=0 Q
  1.  .D ^ASURQ810
  1.  D U^ASUUZIS
  1.  S ASUX("ARST")=$O(^XTMP("ASUR","R81",0))
  1.  I ASUX("ARST")']"" W !!,"No Data for Drop Ship Report for this quarter" G K
  1.  S ASUV("ARST")=ASUX("ARST")
  1.  D ARE^ASULARST($P(^ASUL(1,$E(ASUX("ARST"),1,2),0),U,2))
  1.  S ASUQA("AR")=ASUL(1,"AR","AP")_" - "_ASUL(1,"AR","NM")
  1.  D STA^ASULARST(ASUX("ARST"))
  1.  S ASUQA("STA")=ASUL(2,"STA","CD")_" - "_ASUL(2,"STA","NM")
  1.  S Y=$P(^XTMP("ASUR","R81",0),U) X ^DD("DD") S ASUV("DT")=Y
  1.  S (ASUC("LN"),ASUC("PG"))=0
  1.  S ASUP("YR")=$E($P(^XTMP("ASUR","R81",0),U,2),1,4),ASUT("QTR")=$E($P(^XTMP("ASUR","R81",0),U,2),5,6)
  1.  S ASUQA("DIV")=$S(ASUT("QTR")="04":12,ASUT("QTR")="03":9,ASUT("QTR")="02":6,1:3)
  1.  S ASUX("ACIX")="" K ASUL(9)
  1.  F  S ASUX("ACIX")=$O(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"))) Q:ASUX("ACIX")=""  Q:$D(DTOUT)  Q:$D(DUOUT)  D
  1.  .S ASUMX("ACC")=$E(ASUX("ACIX"))
  1.  .I $G(ASUL(9,"ACC"))'=ASUMX("ACC") D
  1.  ..I $G(ASUL(9,"ACC"))]"" S ASUV("LEV")=1 D PRTOTL
  1.  ..D ACC^ASULDIRF(ASUMX("ACC"))
  1.  ..S ASUQA("ACC")=ASUL(9,"ACC")_" - "_ASUL(9,"ACC","NM")
  1.  .D P1
  1.  I $D(DUOUT)!($D(DTOUT)) G K
  1.  I ASUV("LEV")'=1 D
  1.  .S ASUV("LEV")=1 D PRTOTL
  1.  S ASUV("LEV")=2 D PRTOTL
  1.  D CLS^ASUUHDG
  1. K ;
  1.  K ASUC,ASUF,ASUQA,ASUR,ASUT,ASUV,ASUX,ASURZ,ASURZX,ASUMS
  1.  F X=3:1:22 K ASUL(X) ;Clear Table Lookup fields
  1.  K DFOUT,DIR,DLOUT,DTOUT,DUOUT
  1.  K X,X1,Y
  1.  I ASUK("PTRSEL")]"" Q
  1.  D C^ASUUZIS
  1.  Q
  1. NEWQTR ;EP ;
  1.  ;GLOBAL ASURX IS A UTILITY REPORT EXTRACT GLOBAL
  1.  K ^XTMP("ASUR","R81"),^XTMP("ASUR","R82")
  1.  S ^XTMP("ASUR","R81",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
  1.  S ^XTMP("ASUR","R82",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM") G EN
  1. P1 ;
  1.  S ASUMX("E#","IDX")=$E(ASUX("ACIX"),2,9) D READ^ASUMXDIO
  1.  S ASUX("REQ")="",ASUF("IDX")=0
  1.  F  S ASUX("REQ")=$O(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ"))) Q:ASUX("REQ")=""  Q:$D(DTOUT)  Q:$D(DUOUT)  D
  1.  .S ASUQA=^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ"))
  1.  .I $G(ASUX("SST"))'=$E(ASUX("REQ"),1,5) D
  1.  ..K ASUL(18)
  1.  ..S ASUX("SST")=$E(ASUX("REQ"),1,5)
  1.  ..D SST^ASULDIRR(ASUX("SST"))
  1.  ..S ASUQA("SST")=ASUL(18,"SST")_" - "_ASUL(18,"SST","NM")
  1.  .S ASUV("SST")=ASUX("SST")
  1.  .S $P(ASUQA(0,ASUX("SST")),U)=$P(ASUQA,U)
  1.  .S $P(ASUQA(0,ASUX("SST")),U,2)=$P(ASUQA,U,2)
  1.  .S $P(ASUQA(0,ASUX("SST")),U,3)=$FN(($P(ASUQA,U,2)/ASUQA("DIV")),"",2)
  1.  .S $P(ASUQA(0,ASUX("SST")),U,4)=$P(ASUQA,U,3)
  1.  .S $P(ASUQA(0,ASUX("SST")),U,5)=$P(ASUQA,U,4)
  1.  .S $P(ASUQA(0,ASUX("SST")),U,6)=$FN(($P(ASUQA,U,3)/ASUQA("DIV")),"",2)
  1.  .S ASUV("LEV")=0
  1.  .D P3
  1.  .F X=19,20,22 K ASUL(X)
  1.  .S ASUX("USR")=ASUL(1,"AR","AP")_$E(ASUX("REQ"),6,9)
  1.  .D USR^ASULDIRR(ASUX("USR"))
  1.  .D REQ^ASULDIRR(ASUX("REQ"))
  1.  .S ASUQA("USR")=ASUL(19,"USR")_" - "_ASUL(19,"USR","NM")
  1.  .D:ASUF("HDR") HEADER Q:$D(DUOUT)
  1.  .W ! S ASUC("LN")=ASUC("LN")+1
  1.  .I ASUF("IDX")=1 D
  1.  ..W ?10,ASUMX("DESC",2) S ASUF("IDX")=2
  1.  .E  I ASUF("IDX")=0 D
  1.  ..W ! S ASUC("LN")=ASUC("LN")+1
  1.  ..W ?1,$E(ASUMX("IDX"),1,5)_"."_$E(ASUMX("IDX"),6,6)
  1.  ..W ?10,ASUMX("DESC",1)
  1.  ..W ?45,ASUMX("AR U/I")
  1.  ..S ASUF("IDX")=1
  1.  .D P2
  1.  Q:$D(DTOUT)  Q:$D(DUOUT)
  1.  I ASUF("IDX")=1 W !?10,ASUMX("DESC",2) S ASUC("LN")=ASUC("LN")+1
  1.  I ASUF("IDX") S ASUV("SST")=0 D PRTOTL
  1.  Q
  1. P2 ;
  1.  W ?50,ASUL(18,"SST"),?55,ASUL(19,"USR")
  1. PRLQTY ;
  1.  F ASUV("PIECE")=1:1:3 D
  1.  .S ASURZX=((ASUV("PIECE")-1)*10)+60
  1.  .S ASURZ=$J($FN($P(ASUQA(ASUV("LEV"),ASUV("SST")),U,ASUV("PIECE")),"+,T",0),10)
  1.  .D PRCOLM
  1. PRLVAL ;
  1.  F ASUV("PIECE")=4:1:6 D
  1.  .S ASURZX=((ASUV("PIECE")-4)*12)+90
  1.  .S ASURZ=$J($FN($P(ASUQA(ASUV("LEV"),ASUV("SST")),U,ASUV("PIECE")),"+,T",2),12)
  1.  .D PRCOLM
  1.  I ASUC("LN")>(IOSL-2) S ASUF("HDR")=1
  1.  Q
  1. PRCOLM ;
  1.  W ?ASURZX,ASURZ
  1.  Q
  1. PRTOTL ;
  1.  I ASUC("LN")>(IOSL-ASUV("LEV")*3) S ASUF("HDR")=1
  1.  D:ASUF("HDR") HEADER Q:$D(DUOUT)
  1.  W !,$P($T(TOTNAM+ASUV("LEV")),";",4)
  1.  S ASUC("LN")=ASUC("LN")+1
  1.  S ASUV("SST")=0
  1.  I ASUV("LEV")=0 D
  1.  .D PRDASH
  1.  .W !?35,$P($T(TOTNAM+ASUV("LEV")),";",3)
  1.  .S ASUC("LN")=ASUC("LN")+1
  1.  .D PRLQTY,PRDDSH
  1.  E  D
  1.  .D PRSST
  1.  .S ASUF("HDR")=1
  1.  .S ASUV("SST")=0
  1.  .W !?55,$P($T(TOTNAM+ASUV("LEV")),";",3)
  1.  .S ASUC("LN")=ASUC("LN")+1
  1.  .D PRLVAL
  1.  .W ! D PRDDSHV
  1.  S ASUV("SST")=ASUL(18,"SST","E#")
  1.  K ASUQA(ASUV("LEV"))
  1.  Q
  1. PRDASH ;
  1.  F ASUC=0:1:2 S X=(ASUC*10)+60 W ?X," _________"
  1. PRDASHV ;
  1.  F ASUC=0:1:2 S X=(ASUC*12)+90 W ?X," ___________",?1,""
  1.  S ASUC("LN")=ASUC("LN")+1
  1.  Q
  1. PRDDSH ;
  1.  W !
  1.  F ASUC=0:1:2 S X=(ASUC*10)+60 W ?X," ========="
  1. PRDDSHV ;
  1.  F ASUC=0:1:2 S X=(ASUC*12)+90 W ?X," ===========",?1,""
  1.  S ASUC("LN")=ASUC("LN")+1
  1.  Q
  1. PRSST ;
  1.  S ASUV("SST")=0
  1.  F  S ASUV("SST")=$O(ASUQA(ASUV("LEV"),ASUV("SST"))) Q:ASUV("SST")=""  D
  1.  .W !?50,$E(ASUV("SST"),4,5)
  1.  .W ?55,$P($T(TOTNAM+ASUV("LEV")),";",3)
  1.  .D PRLVAL
  1.  W ! D PRDASHV
  1.  Q
  1.  S ASUC("PG")=ASUC("PG")+1
  1.  D:ASUC("PG")>1 PAZ^ASUURHDR Q:$D(DUOUT)
  1.  W @IOF,!,"REPORT #81 QUARTERLY LISTING OF ITEMS DROP SHIPPED",?70,"DATE : ",ASUV("DT"),?95,"PAGE :",$J(ASUC("PG"),3)
  1.  W !,"AREA: ",ASUQA("AR"),?50,$S(ASUT("QTR")="04":"LAST",ASUT("QTR")="03":"THIRD",ASUT("QTR")="02":"SECOND",1:"1ST")," QUARTER OF FISCAL YEAR ",ASUP("YR")
  1.  S:'$G(ASUQA("ACC")) ASUQA("ACC")=$G(ASUL(9,"ACC"))_"-"_$G(ASUL(9,"ACC","NM"))
  1.  W !,"STAT: ",ASUQA("STA"),?53,"GL ACCOUNT : ",ASUQA("ACC")
  1.  W !!?68,"QUANTITY ISSUED",?96,"ISSUE VALUE          ISSUE VALUE"
  1.  W !?3,"INDEX  ITEM",?45,"U",?49,"SUB",?55,"USER",?64,"CURRENT",?83,"MONTHLY",?96,"CURRENT",?119,"MONTHLY"
  1.  W !?2,"NUMBER  DESCRIPTION",?46,"I",?49,"STA",?55,"CODE",?64,"QUARTER",?76,"Y-T-D",?83,"AVERAGE",?96,"QUARTER",?110,"Y-T-D",?119,"AVERAGE"
  1.  W ! F ASUC=1:1:132 W "_"
  1.  W !!
  1.  S ASUC("LN")=10,ASUF("HDR")=0
  1.  Q
  1. TOTNAM ;;ITEM TOTAL
  1.  ;;GL ACCOUNT TOTAL VALUE;SUMMARY OF DROP SHIPPED BY ACCOUNT
  1.  ;;TOTAL VALUE DROP SHIPPED;SUMMARY OF TOTAL VALUE DROP SHIPPED
  1. P3 ;
  1.  F ASUV("PIECE")=1:1:6 D
  1.  .S ASUQA(0,0)=$G(ASUQA(0,0))
  1.  .S $P(ASUQA(0,0),U,ASUV("PIECE"))=$P(ASUQA(0,0),U,ASUV("PIECE"))+$P(ASUQA(0,ASUX("SST")),U,ASUV("PIECE"))
  1.  F ASUV("LEVA")=0:1:2 D ONE
  1.  Q
  1. ONE ;
  1.  F ASUV("PIECE")=1:1:6 D
  1.  .S ASUQA(ASUV("LEVA")+1,ASUX("SST"))=$G(ASUQA(ASUV("LEVA")+1,ASUX("SST")))
  1.  .S $P(ASUQA(ASUV("LEVA")+1,ASUX("SST")),U,ASUV("PIECE"))=$P(ASUQA(ASUV("LEVA")+1,ASUX("SST")),U,ASUV("PIECE"))+$P(ASUQA(0,ASUX("SST")),U,ASUV("PIECE"))
  1.  .S ASUQA(ASUV("LEVA")+1,0)=$G(ASUQA(ASUV("LEVA")+1,0))
  1.  .S $P(ASUQA(ASUV("LEVA")+1,0),U,ASUV("PIECE"))=$P(ASUQA(ASUV("LEVA")+1,0),U,ASUV("PIECE"))+$P(ASUQA(0,ASUX("SST")),U,ASUV("PIECE"))
  1.  Q