ASURD72P ; IHS/ITSC/LMH -RPT 72 UNDELVRD PO FOLLOW UP ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine formats and prints report 72, Undelivered Purchase Order
;Followup Report.
STANDARD ;EP; FOR STANDARD PRINT
Q ;WAR 5/21/99
;K ^XTMP("ASUR","R72") ;B:$G(JDH) S ^XTMP("ASUR","R72",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
START ;
D DATE^ASUUDATE,TIME^ASUUDATE
S X=ASUK("DT","FM") D H^%DTC S X3=%H D:'$D(IO) HOME^%ZIS
I $D(^XTMP("ASUR","R72")) D CMPT
I '$D(DUZ(2)) W !,"Report must be run from Kernel option" Q
I '$D(ASUL(1,"AR","AP")) D SETAREA^ASULARST
S ASUK("PTRSEL")=$G(ASUK("PTRSEL")) I ASUK("PTRSEL")]"" G PSER
S ZTRTN="PSER^ASURD72P",ZTDESC="SAMS RPT 72" D O^ASUUZIS
I POP S IOP=$I D ^%ZIS Q
I ASUK(ASUK("PTR"),"Q") Q
PSER ;EP;FOR TASKMAN QUEUE OF PRINT
D U^ASUUZIS S ASUC("LN")=IOSL+1,(ASUV("D/IPO#"),ASUV("IDX"))=""
S Y=$P($G(^XTMP("ASUR","R72",0)),U,2) X ^DD("DD") S ASUX("DT")=Y
S X=$O(^XTMP("ASUR","R72",0)) I X']"" S ASUMS("AR")="" D HEADER Q:$D(DIRUT) W !,*7,"NO DATA FOR REPORT #72" W ?27,ASUX("DT") G K
S ASUMS("AR")=$P($G(^ASUMS(X,0)),U,2) I ASUMS("AR")']"" W !,"NO STATION MASTERS LOADED" G K
S (ASUMS("D/I","PO#"),ASUMX("IDX"))=""
;S ASUMS("STA")=$O(^XTMP("ASUR","R72","")) I ASUMS("STA")'>0 G K
S ASUMS("STA")=$O(^XTMP("ASUR","R72",0)) I ASUMS("STA")'>0 G K ; JDH
F S ASUMS("D/I","PO#")=$O(^XTMP("ASUR","R72",ASUMS("STA"),ASUMS("D/I","PO#"))) D Q:ASUMS("D/I","PO#")=""!$D(DIRUT)
.S:ASUV("D/IPO#")="" ASUV("D/IPO#")=ASUMS("D/I","PO#") D:ASUV("D/IPO#")'=ASUMS("D/I","PO#")
..W !!?1,"FOLLOW UP MADE BY:",?41,"DATE:",!!?1,"STATUS:",!
..S ASUC("LN")=IOSL+1,ASUV("D/IPO#")=ASUMS("D/I","PO#")
.Q:ASUV("D/IPO#")']""
.F S ASUMX("IDX")=$O(^XTMP("ASUR","R72",ASUMS("STA"),ASUMS("D/I","PO#"),ASUMX("IDX"))) D Q:ASUMX("IDX")="" Q:$D(DIRUT)
..S:ASUV("IDX")="" ASUV("IDX")=ASUMX("IDX") D:ASUV("IDX")'=ASUMX("IDX") P2 Q:$D(DIRUT) Q:ASUMX("IDX")']"" D P1
K ;
K ASUV,DIC,ASUMX,ASUC,X,X2,X3,Y
F X=3:1:22 K ASUL(X) ;Clear Table Lookup fields
D PAZ^ASUURHDR
I ASUK("PTRSEL")]"" W @IOF Q
;D C^ASUUZIS
Q
REPRINT ;ENTRY TO RECREATE REPORT 72 INCLUDING ITEMS ON LAST PRINT
I '$D(^ASUR7(72,1,0)) G STANDARD
S:'$D(ASUV("R72 LAST DT")) ASUV("R72 LAST DT")=^ASUR7(72,1,0)
G START
P1 ;READ EXTRACT DATA
S ASUX(0)=^XTMP("ASUR","R72",ASUMS("STA"),ASUMS("D/I","PO#"),ASUMX("IDX"))
S ASUMS("D/I","DT")=$P(ASUX(0),U,4)
S ASUMX("DESC",1)=$P(ASUX(0),U,5)
S ASUMX("DESC",2)=$P(ASUX(0),U,6)
S ASUMX("AR U/I")=$P(ASUX(0),U,7)
S ASUMS("D/I","QTY")=$P(ASUX(0),U,8)
S ASUMS("QTY","O/H")=$P(ASUX(0),U,9)
S ASUMS("PMIQ")=$P(ASUX(0),U,10)
S ASUV("PASTDU")=$P(ASUX(0),U,11)
S ASUMS("LTM")=$P(ASUX(0),U,12)
Q
P2 ;RPT 72 UNDELVRD PO FOLLOW UP
I ASUC("LN")>(IOSL-2) D HEADER Q:$D(DIRUT)
W !!?1,$E(ASUV("IDX"),1,5),".",$E(ASUV("IDX"),6,6)
W ?10,ASUMX("DESC",1)
W ?41,ASUMX("AR U/I")
W ?44,$J($FN(ASUMS("D/I","QTY"),","),7)
W ?52,$J($FN(ASUMS("QTY","O/H"),","),8)
W ?60,$J($FN(ASUMS("PMIQ"),","),6)
W ?67,$J($FN(ASUV("PASTDU"),","),6)
W ?74,$E(ASUMS("LTM")),".",$E(ASUMS("LTM"),2,2)
W !?10,ASUMX("DESC",2)
S ASUC("LN")=ASUC("LN")+3,ASUV("IDX")=ASUMX("IDX")
Q
S ASUC("PG")=$G(ASUC("PG"))+1,ASUC("LN")=0
D:ASUC("PG")>1 PAZ^ASUURHDR Q:$D(DIRUT) W @IOF
W !?1,"REPORT #72 UNDELIVERED PURCHASE ORDER -FOLLOW UP REPORT" W ?61,ASUX("DT"),?74,"PAGE ",ASUC("PG")
Q:ASUMS("AR")']"" W !?3,"AREA: ",ASUL(1,"AR","AP"),?15,ASUL(1,"AR","NM")
;D STA^ASULARST(ASUMS("STA")) W !?3,"STAT: ",ASUL(2,"STA"),?15,ASUL(2,"STA","NM")
D STA^ASULARST(ASUMS("STA")) W !?3,"STAT: ",ASUL(2,"STA","E#"),?15,ASUL(2,"STA","NM") ; JDH
W !?1,"PURCHASE ORDER NO. ",ASUV("D/IPO#")," -",?31,"DELIVERY DUE DATE: " S X=ASUMS("D/I","DT") X ^DD("DD") W ?50,X
W !!!?49,"DUE QTY NO.",!?3,"INDEX",?50,"IN",?58,"ON",?68,"DAYS",?75,"LT",!?2,"NUMBER DESCRIPTION",?41,"UI",?49,"QTY",?56,"HAND",?62,"PAMIQ",?68,"LATE",?74,"MOS"
S ASUC("LN")=8 Q
CMPT ;EP ;SORT RPT 72 -XTR ^ASUX
K ^XTMP("ASUR","R72") S ^XTMP("ASUR","R72",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM") D:'$D(ASUK("DT","FM")) DATE^ASUUDATE,TIME^ASUUDATE
S X=ASUK("DT","FM") D H^%DTC S X3=%H
S ASUMS("E#","STA")=0 F S ASUMS("E#","STA")=$O(^ASUMS(ASUMS("E#","STA"))) Q:ASUMS("E#","STA")'?1N.N S ASUMS("E#","IDX")=0 D
.F S ASUMS("E#","IDX")=$O(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX"))) Q:ASUMS("E#","IDX")'?1N.N D
..S ASUV("E#")=ASUMS("E#","IDX") D ^ASUMSTRD
..I ASUF("DLIDX") S ASUMS("E#","IDX")=ASUV("E#") Q
..S ASUF("DUEIN")=0 F ASUV("DUEIN")=1:1:3 D
...Q:ASUMS("D/I","DT",ASUV("DUEIN"))']"" Q:ASUMS("D/I","QTY",ASUV("DUEIN"))']"" Q:ASUMS("D/I","QTY",ASUV("DUEIN"))=0
...I ASUF("DUEIN")=0 S ASUMX("E#","IDX")=ASUMS("E#","IDX") D READ^ASUMXDIO S ASUF("DUEIN")=1
...S ASUV("DUEDT")=ASUMS("D/I","DT",ASUV("DUEIN")) S X=ASUV("DUEDT") D H^%DTC S X2=%H Q:X2>X3
...S ASUV("PASTDU")=X3-X2 Q:ASUV("PASTDU")<0!(ASUV("PASTDU")<7) S ASUF("RPTD")=0
...I ASUMS("D/I","DTR72",ASUV("DUEIN"))?1N.N D
....I $D(ASUV("R72 LAST DT")) Q:ASUMS("D/I","DTR72",ASUV("DUEIN"))=ASUV("R72 LAST DT")
....S X=$E(ASUMS("D/I","DTR72",ASUV("DUEIN")),1,7) D H^%DTC S X2=%H I X2>X3 S ASUF("RPTD")=1 Q
....S ASUV("RPTD")=X3-X2 I ASUV("RPTD")<7 S ASUF("RPTD")=1
...; JDH WHAT DOES 7 DAYS HAVE TO DO WITH LATENESS ;Q:ASUF("RPTD")
...S ASUMS("D/I","DTR72",ASUV("DUEIN"))=ASUK("DT","FM")
...S:ASUMS("D/I","PO#",ASUV("DUEIN"))="" ASUMS("D/I","PO#",ASUV("DUEIN"))=" "
...S X=ASUMS("STA")_U_ASUMS("D/I","PO#",ASUV("DUEIN"))_U_ASUMX("IDX")_U_ASUMS("D/I","DT",ASUV("DUEIN"))_U_ASUMX("DESC",1)_U_ASUMX("DESC",2)
...S X=X_U_ASUMX("AR U/I")_U_ASUMS("D/I","QTY",ASUV("DUEIN"))_U_ASUMS("QTY","O/H")_U_ASUMS("PMIQ")_U_ASUV("PASTDU")_U_ASUMS("LTM")
...S ^XTMP("ASUR","R72",ASUMS("STA"),ASUMS("D/I","PO#",ASUV("DUEIN")),ASUMX("IDX"))=X
...K X Q
..D:ASUF("DUEIN") ^ASUMSTWR
K ASUV,ASUF("DUEIN"),ASUF("RPTD"),ASUMX,ASUMS
Q
ASURD72P ; IHS/ITSC/LMH -RPT 72 UNDELVRD PO FOLLOW UP ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine formats and prints report 72, Undelivered Purchase Order
+3 ;Followup Report.
STANDARD ;EP; FOR STANDARD PRINT
+1 ;WAR 5/21/99
QUIT
+2 ;K ^XTMP("ASUR","R72") ;B:$G(JDH) S ^XTMP("ASUR","R72",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
START ;
+1 DO DATE^ASUUDATE
DO TIME^ASUUDATE
+2 SET X=ASUK("DT","FM")
DO H^%DTC
SET X3=%H
IF '$DATA(IO)
DO HOME^%ZIS
+3 IF $DATA(^XTMP("ASUR","R72"))
DO CMPT
+4 IF '$DATA(DUZ(2))
WRITE !,"Report must be run from Kernel option"
QUIT
+5 IF '$DATA(ASUL(1,"AR","AP"))
DO SETAREA^ASULARST
+6 SET ASUK("PTRSEL")=$GET(ASUK("PTRSEL"))
IF ASUK("PTRSEL")]""
GOTO PSER
+7 SET ZTRTN="PSER^ASURD72P"
SET ZTDESC="SAMS RPT 72"
DO O^ASUUZIS
+8 IF POP
SET IOP=$IO
DO ^%ZIS
QUIT
+9 IF ASUK(ASUK("PTR"),"Q")
QUIT
PSER ;EP;FOR TASKMAN QUEUE OF PRINT
+1 DO U^ASUUZIS
SET ASUC("LN")=IOSL+1
SET (ASUV("D/IPO#"),ASUV("IDX"))=""
+2 SET Y=$PIECE($GET(^XTMP("ASUR","R72",0)),U,2)
XECUTE ^DD("DD")
SET ASUX("DT")=Y
+3 SET X=$ORDER(^XTMP("ASUR","R72",0))
IF X']""
SET ASUMS("AR")=""
DO HEADER
IF $DATA(DIRUT)
QUIT
WRITE !,*7,"NO DATA FOR REPORT #72"
WRITE ?27,ASUX("DT")
GOTO K
+4 SET ASUMS("AR")=$PIECE($GET(^ASUMS(X,0)),U,2)
IF ASUMS("AR")']""
WRITE !,"NO STATION MASTERS LOADED"
GOTO K
+5 SET (ASUMS("D/I","PO#"),ASUMX("IDX"))=""
+6 ;S ASUMS("STA")=$O(^XTMP("ASUR","R72","")) I ASUMS("STA")'>0 G K
+7 ; JDH
SET ASUMS("STA")=$ORDER(^XTMP("ASUR","R72",0))
IF ASUMS("STA")'>0
GOTO K
+8 FOR
SET ASUMS("D/I","PO#")=$ORDER(^XTMP("ASUR","R72",ASUMS("STA"),ASUMS("D/I","PO#")))
Begin DoDot:1
+9 IF ASUV("D/IPO#")=""
SET ASUV("D/IPO#")=ASUMS("D/I","PO#")
IF ASUV("D/IPO#")'=ASUMS("D/I","PO#")
Begin DoDot:2
+10 WRITE !!?1,"FOLLOW UP MADE BY:",?41,"DATE:",!!?1,"STATUS:",!
+11 SET ASUC("LN")=IOSL+1
SET ASUV("D/IPO#")=ASUMS("D/I","PO#")
End DoDot:2
+12 IF ASUV("D/IPO#")']""
QUIT
+13 FOR
SET ASUMX("IDX")=$ORDER(^XTMP("ASUR","R72",ASUMS("STA"),ASUMS("D/I","PO#"),ASUMX("IDX")))
Begin DoDot:2
+14 IF ASUV("IDX")=""
SET ASUV("IDX")=ASUMX("IDX")
IF ASUV("IDX")'=ASUMX("IDX")
DO P2
IF $DATA(DIRUT)
QUIT
IF ASUMX("IDX")']""
QUIT
DO P1
End DoDot:2
IF ASUMX("IDX")=""
QUIT
IF $DATA(DIRUT)
QUIT
End DoDot:1
IF ASUMS("D/I","PO#")=""!$DATA(DIRUT)
QUIT
K ;
+1 KILL ASUV,DIC,ASUMX,ASUC,X,X2,X3,Y
+2 ;Clear Table Lookup fields
FOR X=3:1:22
KILL ASUL(X)
+3 DO PAZ^ASUURHDR
+4 IF ASUK("PTRSEL")]""
WRITE @IOF
QUIT
+5 ;D C^ASUUZIS
+6 QUIT
REPRINT ;ENTRY TO RECREATE REPORT 72 INCLUDING ITEMS ON LAST PRINT
+1 IF '$DATA(^ASUR7(72,1,0))
GOTO STANDARD
+2 IF '$DATA(ASUV("R72 LAST DT"))
SET ASUV("R72 LAST DT")=^ASUR7(72,1,0)
+3 GOTO START
P1 ;READ EXTRACT DATA
+1 SET ASUX(0)=^XTMP("ASUR","R72",ASUMS("STA"),ASUMS("D/I","PO#"),ASUMX("IDX"))
+2 SET ASUMS("D/I","DT")=$PIECE(ASUX(0),U,4)
+3 SET ASUMX("DESC",1)=$PIECE(ASUX(0),U,5)
+4 SET ASUMX("DESC",2)=$PIECE(ASUX(0),U,6)
+5 SET ASUMX("AR U/I")=$PIECE(ASUX(0),U,7)
+6 SET ASUMS("D/I","QTY")=$PIECE(ASUX(0),U,8)
+7 SET ASUMS("QTY","O/H")=$PIECE(ASUX(0),U,9)
+8 SET ASUMS("PMIQ")=$PIECE(ASUX(0),U,10)
+9 SET ASUV("PASTDU")=$PIECE(ASUX(0),U,11)
+10 SET ASUMS("LTM")=$PIECE(ASUX(0),U,12)
+11 QUIT
P2 ;RPT 72 UNDELVRD PO FOLLOW UP
+1 IF ASUC("LN")>(IOSL-2)
DO HEADER
IF $DATA(DIRUT)
QUIT
+2 WRITE !!?1,$EXTRACT(ASUV("IDX"),1,5),".",$EXTRACT(ASUV("IDX"),6,6)
+3 WRITE ?10,ASUMX("DESC",1)
+4 WRITE ?41,ASUMX("AR U/I")
+5 WRITE ?44,$JUSTIFY($FNUMBER(ASUMS("D/I","QTY"),","),7)
+6 WRITE ?52,$JUSTIFY($FNUMBER(ASUMS("QTY","O/H"),","),8)
+7 WRITE ?60,$JUSTIFY($FNUMBER(ASUMS("PMIQ"),","),6)
+8 WRITE ?67,$JUSTIFY($FNUMBER(ASUV("PASTDU"),","),6)
+9 WRITE ?74,$EXTRACT(ASUMS("LTM")),".",$EXTRACT(ASUMS("LTM"),2,2)
+10 WRITE !?10,ASUMX("DESC",2)
+11 SET ASUC("LN")=ASUC("LN")+3
SET ASUV("IDX")=ASUMX("IDX")
+12 QUIT
+1 SET ASUC("PG")=$GET(ASUC("PG"))+1
SET ASUC("LN")=0
+2 IF ASUC("PG")>1
DO PAZ^ASUURHDR
IF $DATA(DIRUT)
QUIT
WRITE @IOF
+3 WRITE !?1,"REPORT #72 UNDELIVERED PURCHASE ORDER -FOLLOW UP REPORT"
WRITE ?61,ASUX("DT"),?74,"PAGE ",ASUC("PG")
+4 IF ASUMS("AR")']""
QUIT
WRITE !?3,"AREA: ",ASUL(1,"AR","AP"),?15,ASUL(1,"AR","NM")
+5 ;D STA^ASULARST(ASUMS("STA")) W !?3,"STAT: ",ASUL(2,"STA"),?15,ASUL(2,"STA","NM")
+6 ; JDH
DO STA^ASULARST(ASUMS("STA"))
WRITE !?3,"STAT: ",ASUL(2,"STA","E#"),?15,ASUL(2,"STA","NM")
+7 WRITE !?1,"PURCHASE ORDER NO. ",ASUV("D/IPO#")," -",?31,"DELIVERY DUE DATE: "
SET X=ASUMS("D/I","DT")
XECUTE ^DD("DD")
WRITE ?50,X
+8 WRITE !!!?49,"DUE QTY NO.",!?3,"INDEX",?50,"IN",?58,"ON",?68,"DAYS",?75,"LT",!?2,"NUMBER DESCRIPTION",?41,"UI",?49,"QTY",?56,"HAND",?62,"PAMIQ",?68,"LATE",?74,"MOS"
+9 SET ASUC("LN")=8
QUIT
CMPT ;EP ;SORT RPT 72 -XTR ^ASUX
+1 KILL ^XTMP("ASUR","R72")
SET ^XTMP("ASUR","R72",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
IF '$DATA(ASUK("DT","FM"))
DO DATE^ASUUDATE
DO TIME^ASUUDATE
+2 SET X=ASUK("DT","FM")
DO H^%DTC
SET X3=%H
+3 SET ASUMS("E#","STA")=0
FOR
SET ASUMS("E#","STA")=$ORDER(^ASUMS(ASUMS("E#","STA")))
IF ASUMS("E#","STA")'?1N.N
QUIT
SET ASUMS("E#","IDX")=0
Begin DoDot:1
+4 FOR
SET ASUMS("E#","IDX")=$ORDER(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX")))
IF ASUMS("E#","IDX")'?1N.N
QUIT
Begin DoDot:2
+5 SET ASUV("E#")=ASUMS("E#","IDX")
DO ^ASUMSTRD
+6 IF ASUF("DLIDX")
SET ASUMS("E#","IDX")=ASUV("E#")
QUIT
+7 SET ASUF("DUEIN")=0
FOR ASUV("DUEIN")=1:1:3
Begin DoDot:3
+8 IF ASUMS("D/I","DT",ASUV("DUEIN"))']""
QUIT
IF ASUMS("D/I","QTY",ASUV("DUEIN"))']""
QUIT
IF ASUMS("D/I","QTY",ASUV("DUEIN"))=0
QUIT
+9 IF ASUF("DUEIN")=0
SET ASUMX("E#","IDX")=ASUMS("E#","IDX")
DO READ^ASUMXDIO
SET ASUF("DUEIN")=1
+10 SET ASUV("DUEDT")=ASUMS("D/I","DT",ASUV("DUEIN"))
SET X=ASUV("DUEDT")
DO H^%DTC
SET X2=%H
IF X2>X3
QUIT
+11 SET ASUV("PASTDU")=X3-X2
IF ASUV("PASTDU")<0!(ASUV("PASTDU")<7)
QUIT
SET ASUF("RPTD")=0
+12 IF ASUMS("D/I","DTR72",ASUV("DUEIN"))?1N.N
Begin DoDot:4
+13 IF $DATA(ASUV("R72 LAST DT"))
IF ASUMS("D/I","DTR72",ASUV("DUEIN"))=ASUV("R72 LAST DT")
QUIT
+14 SET X=$EXTRACT(ASUMS("D/I","DTR72",ASUV("DUEIN")),1,7)
DO H^%DTC
SET X2=%H
IF X2>X3
SET ASUF("RPTD")=1
QUIT
+15 SET ASUV("RPTD")=X3-X2
IF ASUV("RPTD")<7
SET ASUF("RPTD")=1
End DoDot:4
+16 ; JDH WHAT DOES 7 DAYS HAVE TO DO WITH LATENESS ;Q:ASUF("RPTD")
+17 SET ASUMS("D/I","DTR72",ASUV("DUEIN"))=ASUK("DT","FM")
+18 IF ASUMS("D/I","PO#",ASUV("DUEIN"))=""
SET ASUMS("D/I","PO#",ASUV("DUEIN"))=" "
+19 SET X=ASUMS("STA")_U_ASUMS("D/I","PO#",ASUV("DUEIN"))_U_ASUMX("IDX")_U_ASUMS("D/I","DT",ASUV("DUEIN"))_U_ASUMX("DESC",1)_U_ASUMX("DESC",2)
+20 SET X=X_U_ASUMX("AR U/I")_U_ASUMS("D/I","QTY",ASUV("DUEIN"))_U_ASUMS("QTY","O/H")_U_ASUMS("PMIQ")_U_ASUV("PASTDU")_U_ASUMS("LTM")
+21 SET ^XTMP("ASUR","R72",ASUMS("STA"),ASUMS("D/I","PO#",ASUV("DUEIN")),ASUMX("IDX"))=X
+22 KILL X
QUIT
End DoDot:3
+23 IF ASUF("DUEIN")
DO ^ASUMSTWR
End DoDot:2
End DoDot:1
+24 KILL ASUV,ASUF("DUEIN"),ASUF("RPTD"),ASUMX,ASUMS
+25 QUIT
