ASURO46P ; IHS/ITSC/LMH - REPORT 46 ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine creates report 46 Analysis of Stock Issues by Vendor
;^XTMP("ASUR","R46",AREA,STATION,ACCOUNT,VENDOR,DESCRIPTION)
K %ZIS,IOP,IO("Q") S %ZIS="QM" D ^%ZIS I POP W !,"No device selected or report queued." G KIL
I $D(IO("Q")) K IO("Q") S ZTIO=ION K ZTSAVE,ZTDTH,ZTSK S ZTRTN="QUE^ASURP",ZTSAVE("DUZ*")="",ZTDTH=$H D ^%ZTLOAD W !,"Queued" G KIL
QUE ;EP; for task man
D ASUR0
D KIL U IO
;Set header values
D SETHEADR
D S ASUREND=1 D VSCS(.ASURVSCT) D PAZ^ASUURHDR W @IOF D ^%ZISC,KIL
.F S ASURD1=$O(^XTMP("ASUR","R46",$G(ASURD1))) Q:ASURD1="" D Q:$D(DUOUT)
..F S ASURD2=$O(^XTMP("ASUR","R46",ASURD1,$G(ASURD2))) Q:ASURD2="" D Q:$D(DUOUT)
...F S ASURD3=$O(^XTMP("ASUR","R46",ASURD1,ASURD2,$G(ASURD3))) Q:ASURD3="" D Q:$D(DUOUT)
....K ASURVSCA
....F S ASURD4=$O(^XTMP("ASUR","R46",ASURD1,ASURD2,ASURD3,$G(ASURD4))) Q:ASURD4="" D D HEADER Q:$D(DUOUT)
.....K ASURVSCS
.....F D NEWPAGE W ! S ASURD5=$O(^XTMP("ASUR","R46",ASURD1,ASURD2,ASURD3,ASURD4,$G(ASURD5))) Q:ASURD5="" S ASUR("DTA")=^(ASURD5) D SETDATA
.....D VSCS(.ASURVSCS)
....D VSCS(.ASURVSCA)
Q
VSCS(X) ;Print out Vendor Source Code Summary
;Formal Param is X(SOURCE CODE)=PROJECT ANNUAL ISS VAL^NUM LINE ITEMS
;Actual parameters are as follows:
;ASURVSCS -Totals for each separate vendor
;ASURVSCT -Totals for all vendors on report
;ASURVSCA -Totals for all vendors for each account 1,3 other
I $D(ASUREND) W @IOF,"REPORT # 46 ANALYSIS OF STOCK ITEM BY VENDOR",?65,ASUR("DT"),?112,"PAGE ",ASUR("PG")+1,!,"SUMMARY PAGE"
K ASUR("T1"),ASUR("T2")
D NEWPAGE W !!!?6,"VENDOR SOURCE CODE SUMMARY:",?36,"SOU CDE",?60,"NO. LI",?79,"PROJ ANN ISS VAL"
F D NEWPAGE S Y=$O(X($G(Y))) Q:Y="" W !?35,$J(Y,8),?60,$J($FN($P(X(Y),U,2),","),6),?80,$J($FN($P(X(Y),U),","),15) D
.S ASUR("T1")=$G(ASUR("T1"))+$P(X(Y),U) ;Total for PAIV
.S ASUR("T2")=$G(ASUR("T2"))+$P(X(Y),U,2) ;Total for NO. LI
K Y
D NEWPAGE W !?38,"TOTAL",?60,$J($FN($G(ASUR("T2")),","),6),?80,$J($FN($G(ASUR("T1")),","),15)
Q
;
NEWPAGE ;Form Feed
I $Y+4>IOSL D HEADER Q:$D(DUOUT)
Q
KIL ;Kill
K ASURD1,ASURD2,ASURD3,ASURD4,ASURD5,ASURDL,ASUR1
K ASURVSCS,ASURVSCT,ASUREND
ASUR0 ;
D KILL K ^XTMP("ASUR","R46")
S ^XTMP("ASUR","R46",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
F ASUMS("E#","STA")=0:0 S ASUMS("E#","STA")=$O(^ASUMS(ASUMS("E#","STA"))) Q:'ASUMS("E#","STA") D
.F ASUMS("E#","IDX")=0:0 S ASUMS("E#","IDX")=$O(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX"))) Q:'ASUMS("E#","IDX") D
..D ^ASUMSTRD S ASUMX("E#","IDX")=ASUMS("E#","IDX") D READ^ASUMXDIO
..D ARE^ASULARST(ASUMS("AR")),STA^ASULARST(ASUMS("E#","STA"))
..S ASUR("ACC")=ASUMX("ACC") I ASUMX("ACC")'=1,ASUMX("ACC")'=3 S ASUR("ACC")=4
..S ASUR("IDX")=$E(ASUMX("IDX"),1,5)_"."_$E(ASUMX("IDX"),6)
..S ASUR("DESC")=ASUMX("DESC",1)_" "_ASUMX("DESC",2)
..S ASUR("PMIV")=ASUMS("PMIV")*12,ASUR("PMIV")=$FN(ASUR("PMIV"),"+",0)
..D
...S X=ASUMS("SLC")_U_ASUR("IDX")_U_ASUMX("DESC",1)_U_ASUMX("DESC",2)_U_ASUMX("AR U/I")_U_ASUMS("ORD#")_U_ASUMX("NSN")
...S X=X_U_ASUMS("SRC")_U_ASUMS("LTM")_U_ASUMS("EOQ","TP")_U_ASUMS("LPP")_U_ASUMS("PMIQ")_U_ASUMS("DMD","QTY")_U_ASUR("PMIV")
...S ASUR("VEN")=$S(ASUMS("VENAM")]"":ASUMS("VENAM"),1:"*")
...S ASUR("AR/NM")=ASUMS("AR")_"-"_ASUL(1,"AR","NM"),ASUR("STA/NM")=ASUL(2,"STA","CD")_"-"_ASUL(2,"STA","NM")
...S ^XTMP("ASUR","R46",ASUR("AR/NM"),ASUR("STA/NM"),ASUR("ACC"),ASUR("VEN"),ASUR("DESC"))=X
KILL ;Kill
K ASUR,ASU1,ASU2,ASU3,ASUMS,ASUMX
Q
SETHEADR ;EP; -Set hdr
;Hdr 1
S ASU1(1)="S",ASU1(2)="LAST",ASU1(3)="PREV",ASU1(4)="PROJ ANN"
;
;Hdr 2
S ASU2(1)="L",ASU2(2)="INDEX",ASU2(3)="ORDER",ASU2(4)="SOU",ASU2(5)="LT",ASU2(6)="T",ASU2(7)="PURCHASE",ASU2(8)="12 MOS",ASU2(9)="ISSUE"
;
;Hdr 3
S ASU3(1)="C",ASU3(2)="NUMBER",ASU3(3)="DESCRIPTION",ASU3(4)="U/I",ASU3(5)="NUMBER",ASU3(6)="CDE",ASU3(7)="MOS",ASU3(8)="C",ASU3(9)="PRICE"
S ASU3(10)="PAMIQ",ASU3(11)="USAGE",ASU3(12)="VALUE"
Q
;
S:'$D(ASUR("LN")) $P(ASUR("LN"),"=",123)="="
I '$D(ASUR("DT")) D NOW^%DTC S Y=% X ^DD("DD") S ASUR("DT")=$P(Y,"@")
S ASUR("PG")=$G(ASUR("PG"))+1 D:ASUR("PG")>1 PAZ^ASUURHDR Q:$D(DUOUT) W @IOF
W "REPORT # 46 ANALYSIS OF STOCK ITEM BY VENDOR",?65,ASUR("DT"),?112,"PAGE ",ASUR("PG"),!,"AREA : ",ASURD1
W !,"STATION: ",ASURD2,?50,"CATEGORY: ",$S(ASURD3=1:"PHARMACY",ASURD3=3:"SUBSISTENCE",1:"GENERAL SUPPLIES"),?86,"VENDOR NAME: ",ASURD4
;
;Hdr1
W !!!,ASU1(1),?86,ASU1(2),?105,ASU1(3),?115,ASU1(4)
;
;Hdr2
W !,ASU2(1),?5,ASU2(2),?48,ASU2(3),?69,ASU2(4),?74,ASU2(5),?79,ASU2(6),?82,ASU2(7),?103,ASU2(8),?118,ASU2(9)
;
;Hdr 3
W !,ASU3(1),?4,ASU3(2),?12,ASU3(3),?44,ASU3(4),?48,ASU3(5),?69,ASU3(6),?74,ASU3(7),?79,ASU3(8),?85,ASU3(9),?94,ASU3(10),?104,ASU3(11),?118,ASU3(12)
;
W !,ASUR("LN")
W !
Q
SETDATA ;Set DATA line
S ASURDL(1)=$P(ASUR("DTA"),U) ;SLC-Storage location code
S ASURDL(2)=$P(ASUR("DTA"),U,2) ;IDX-index number grouped as 5-1
S ASURDL(3)=$P(ASUR("DTA"),U,3) ;DSC1-Description 1
S ASURDL(4)=$P(ASUR("DTA"),U,5) ;AUI-Area Unit of issue
S ASUR=$P(ASUR("DTA"),U,6) S ASURDL(5)=$$ON(ASUR) ;VON-Vendor order number
S ASURDL(6)=$P(ASUR("DTA"),U,8) ;SRC-Source code
S ASURDL(7)=$P(ASUR("DTA"),U,9) ;LTM-Lead Time Months
S ASURDL(8)=$P(ASUR("DTA"),U,10) ;TC-Type Code
S ASURDL(9)=$P(ASUR("DTA"),U,11) ;LPP-Last Purchase Price
S ASURDL(10)=$P(ASUR("DTA"),U,12) ;PAMIQ-Projected Average Mon Iss Qnt
S ASURDL(11)=$P(ASUR("DTA"),U,13) ;P12MU-Prev 12 Months Issue Qnt
S ASURDL(12)=$P(ASUR("DTA"),U,14) ;PAIV-Projected Annual Issue Value
S ASURDL(13)=$P(ASUR("DTA"),U,4) ;DSC2-Description 2
S ASURDL(14)=$P(ASUR("DTA"),U,7) ;NSN-National Stock Number
;
S:'$D(ASURVSCS(ASURDL(6))) ASURVSCS(ASURDL(6))=""
S $P(ASURVSCS(ASURDL(6)),U)=$P(ASURVSCS(ASURDL(6)),U)+ASURDL(12),$P(ASURVSCS(ASURDL(6)),U,2)=$P(ASURVSCS(ASURDL(6)),U,2)+1
S:'$D(ASURVSCT(ASURDL(6))) ASURVSCT(ASURDL(6))=""
S $P(ASURVSCT(ASURDL(6)),U)=$P(ASURVSCT(ASURDL(6)),U)+ASURDL(12),$P(ASURVSCT(ASURDL(6)),U,2)=$P(ASURVSCT(ASURDL(6)),U,2)+1
S:'$D(ASURVSCA(ASURDL(6))) ASURVSCA(ASURDL(6))=""
S $P(ASURVSCA(ASURDL(6)),U)=$P(ASURVSCA(ASURDL(6)),U)+ASURDL(12),$P(ASURVSCA(ASURDL(6)),U,2)=$P(ASURVSCA(ASURDL(6)),U,2)+1
;Print data line
W ! D NEWPAGE D OUT(.ASURDL)
Q
;
OUT(X) ;Print Data line
;Formal Parameter is X(1-14)
;Actual Parameter is ASURDL(1-14)
W X(1)
W ?3,X(2)
W ?12,X(3)
W ?44,X(4)
W ?48,X(5)
W ?69,X(6)
W ?74,X(7)
W ?79,X(8)
W ?83,$J(X(9),7,2)
W ?94,$J(X(10),5)
W ?103,$J(X(11),6)
W ?114,$J($FN(X(12),","),9)
W ! D NEWPAGE
W ?12,X(13)
Q
;
ON(X) ;EP; -Set VENDOR ORDER NUMBER -EXTRINSIC
;Set X into requested print format
;Actual parameter is ASUR
;Formal parameter is X
;If X]"" print as follows:
; $E(X)="M" ....Print as stored
; "M" ....4-2-3-5 grouping
;If X="" print as follows:
; ASURDL(14) ....4-2-3-5 grouping
I X]"",$E(X)="M" Q X
I X]"" S X=$E(X,1,4)_"-"_$E(X,5,6)_"-"_$E(X,7,9)_"-"_$E(X,10,9999) Q X
S X=ASURDL(14),X=$E(X,1,4)_"-"_$E(X,5,6)_"-"_$E(X,7,9)_"-"_$E(X,10,999) Q X
Q
ASURO46P ; IHS/ITSC/LMH - REPORT 46 ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine creates report 46 Analysis of Stock Issues by Vendor
+3 ;^XTMP("ASUR","R46",AREA,STATION,ACCOUNT,VENDOR,DESCRIPTION)
+4 KILL %ZIS,IOP,IO("Q")
SET %ZIS="QM"
DO ^%ZIS
IF POP
WRITE !,"No device selected or report queued."
GOTO KIL
+5 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTIO=ION
KILL ZTSAVE,ZTDTH,ZTSK
SET ZTRTN="QUE^ASURP"
SET ZTSAVE("DUZ*")=""
SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
WRITE !,"Queued"
GOTO KIL
QUE ;EP; for task man
+1 DO ASUR0
+2 DO KIL
USE IO
+3 ;Set header values
+4 DO SETHEADR
+5 Begin DoDot:1
+6 FOR
SET ASURD1=$ORDER(^XTMP("ASUR","R46",$GET(ASURD1)))
IF ASURD1=""
QUIT
Begin DoDot:2
+7 FOR
SET ASURD2=$ORDER(^XTMP("ASUR","R46",ASURD1,$GET(ASURD2)))
IF ASURD2=""
QUIT
Begin DoDot:3
+8 FOR
SET ASURD3=$ORDER(^XTMP("ASUR","R46",ASURD1,ASURD2,$GET(ASURD3)))
IF ASURD3=""
QUIT
Begin DoDot:4
+9 KILL ASURVSCA
+10 FOR
SET ASURD4=$ORDER(^XTMP("ASUR","R46",ASURD1,ASURD2,ASURD3,$GET(ASURD4)))
IF ASURD4=""
QUIT
Begin DoDot:5
+11 KILL ASURVSCS
+12 FOR
DO NEWPAGE
WRITE !
SET ASURD5=$ORDER(^XTMP("ASUR","R46",ASURD1,ASURD2,ASURD3,ASURD4,$GET(ASURD5)))
IF ASURD5=""
QUIT
SET ASUR("DTA")=^(ASURD5)
DO SETDATA
+13 DO VSCS(.ASURVSCS)
End DoDot:5
DO HEADER
IF $DATA(DUOUT)
QUIT
+14 DO VSCS(.ASURVSCA)
End DoDot:4
IF $DATA(DUOUT)
QUIT
End DoDot:3
IF $DATA(DUOUT)
QUIT
End DoDot:2
IF $DATA(DUOUT)
QUIT
End DoDot:1
SET ASUREND=1
DO VSCS(.ASURVSCT)
DO PAZ^ASUURHDR
WRITE @IOF
DO ^%ZISC
DO KIL
+15 QUIT
VSCS(X) ;Print out Vendor Source Code Summary
+1 ;Formal Param is X(SOURCE CODE)=PROJECT ANNUAL ISS VAL^NUM LINE ITEMS
+2 ;Actual parameters are as follows:
+3 ;ASURVSCS -Totals for each separate vendor
+4 ;ASURVSCT -Totals for all vendors on report
+5 ;ASURVSCA -Totals for all vendors for each account 1,3 other
+6 IF $DATA(ASUREND)
WRITE @IOF,"REPORT # 46 ANALYSIS OF STOCK ITEM BY VENDOR",?65,ASUR("DT"),?112,"PAGE ",ASUR("PG")+1,!,"SUMMARY PAGE"
+7 KILL ASUR("T1"),ASUR("T2")
+8 DO NEWPAGE
WRITE !!!?6,"VENDOR SOURCE CODE SUMMARY:",?36,"SOU CDE",?60,"NO. LI",?79,"PROJ ANN ISS VAL"
+9 FOR
DO NEWPAGE
SET Y=$ORDER(X($GET(Y)))
IF Y=""
QUIT
WRITE !?35,$JUSTIFY(Y,8),?60,$JUSTIFY($FNUMBER($PIECE(X(Y),U,2),","),6),?80,$JUSTIFY($FNUMBER($PIECE(X(Y),U),","),15)
Begin DoDot:1
+10 ;Total for PAIV
SET ASUR("T1")=$GET(ASUR("T1"))+$PIECE(X(Y),U)
+11 ;Total for NO. LI
SET ASUR("T2")=$GET(ASUR("T2"))+$PIECE(X(Y),U,2)
End DoDot:1
+12 KILL Y
+13 DO NEWPAGE
WRITE !?38,"TOTAL",?60,$JUSTIFY($FNUMBER($GET(ASUR("T2")),","),6),?80,$JUSTIFY($FNUMBER($GET(ASUR("T1")),","),15)
+14 QUIT
+15 ;
NEWPAGE ;Form Feed
+1 IF $Y+4>IOSL
DO HEADER
IF $DATA(DUOUT)
QUIT
+2 QUIT
KIL ;Kill
+1 KILL ASURD1,ASURD2,ASURD3,ASURD4,ASURD5,ASURDL,ASUR1
+2 KILL ASURVSCS,ASURVSCT,ASUREND
ASUR0 ;
+1 DO KILL
KILL ^XTMP("ASUR","R46")
+2 SET ^XTMP("ASUR","R46",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
+3 FOR ASUMS("E#","STA")=0:0
SET ASUMS("E#","STA")=$ORDER(^ASUMS(ASUMS("E#","STA")))
IF 'ASUMS("E#","STA")
QUIT
Begin DoDot:1
+4 FOR ASUMS("E#","IDX")=0:0
SET ASUMS("E#","IDX")=$ORDER(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX")))
IF 'ASUMS("E#","IDX")
QUIT
Begin DoDot:2
+5 DO ^ASUMSTRD
SET ASUMX("E#","IDX")=ASUMS("E#","IDX")
DO READ^ASUMXDIO
+6 DO ARE^ASULARST(ASUMS("AR"))
DO STA^ASULARST(ASUMS("E#","STA"))
+7 SET ASUR("ACC")=ASUMX("ACC")
IF ASUMX("ACC")'=1
IF ASUMX("ACC")'=3
SET ASUR("ACC")=4
+8 SET ASUR("IDX")=$EXTRACT(ASUMX("IDX"),1,5)_"."_$EXTRACT(ASUMX("IDX"),6)
+9 SET ASUR("DESC")=ASUMX("DESC",1)_" "_ASUMX("DESC",2)
+10 SET ASUR("PMIV")=ASUMS("PMIV")*12
SET ASUR("PMIV")=$FNUMBER(ASUR("PMIV"),"+",0)
+11 Begin DoDot:3
+12 SET X=ASUMS("SLC")_U_ASUR("IDX")_U_ASUMX("DESC",1)_U_ASUMX("DESC",2)_U_ASUMX("AR U/I")_U_ASUMS("ORD#")_U_ASUMX("NSN")
+13 SET X=X_U_ASUMS("SRC")_U_ASUMS("LTM")_U_ASUMS("EOQ","TP")_U_ASUMS("LPP")_U_ASUMS("PMIQ")_U_ASUMS("DMD","QTY")_U_ASUR("PMIV")
+14 SET ASUR("VEN")=$SELECT(ASUMS("VENAM")]"":ASUMS("VENAM"),1:"*")
+15 SET ASUR("AR/NM")=ASUMS("AR")_"-"_ASUL(1,"AR","NM")
SET ASUR("STA/NM")=ASUL(2,"STA","CD")_"-"_ASUL(2,"STA","NM")
+16 SET ^XTMP("ASUR","R46",ASUR("AR/NM"),ASUR("STA/NM"),ASUR("ACC"),ASUR("VEN"),ASUR("DESC"))=X
End DoDot:3
End DoDot:2
End DoDot:1
KILL ;Kill
+1 KILL ASUR,ASU1,ASU2,ASU3,ASUMS,ASUMX
+2 QUIT
SETHEADR ;EP; -Set hdr
+1 ;Hdr 1
+2 SET ASU1(1)="S"
SET ASU1(2)="LAST"
SET ASU1(3)="PREV"
SET ASU1(4)="PROJ ANN"
+3 ;
+4 ;Hdr 2
+5 SET ASU2(1)="L"
SET ASU2(2)="INDEX"
SET ASU2(3)="ORDER"
SET ASU2(4)="SOU"
SET ASU2(5)="LT"
SET ASU2(6)="T"
SET ASU2(7)="PURCHASE"
SET ASU2(8)="12 MOS"
SET ASU2(9)="ISSUE"
+6 ;
+7 ;Hdr 3
+8 SET ASU3(1)="C"
SET ASU3(2)="NUMBER"
SET ASU3(3)="DESCRIPTION"
SET ASU3(4)="U/I"
SET ASU3(5)="NUMBER"
SET ASU3(6)="CDE"
SET ASU3(7)="MOS"
SET ASU3(8)="C"
SET ASU3(9)="PRICE"
+9 SET ASU3(10)="PAMIQ"
SET ASU3(11)="USAGE"
SET ASU3(12)="VALUE"
+10 QUIT
+11 ;
+1 IF '$DATA(ASUR("LN"))
SET $PIECE(ASUR("LN"),"=",123)="="
+2 IF '$DATA(ASUR("DT"))
DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
SET ASUR("DT")=$PIECE(Y,"@")
+3 SET ASUR("PG")=$GET(ASUR("PG"))+1
IF ASUR("PG")>1
DO PAZ^ASUURHDR
IF $DATA(DUOUT)
QUIT
WRITE @IOF
+4 WRITE "REPORT # 46 ANALYSIS OF STOCK ITEM BY VENDOR",?65,ASUR("DT"),?112,"PAGE ",ASUR("PG"),!,"AREA : ",ASURD1
+5 WRITE !,"STATION: ",ASURD2,?50,"CATEGORY: ",$SELECT(ASURD3=1:"PHARMACY",ASURD3=3:"SUBSISTENCE",1:"GENERAL SUPPLIES"),?86,"VENDOR NAME: ",ASURD4
+6 ;
+7 ;Hdr1
+8 WRITE !!!,ASU1(1),?86,ASU1(2),?105,ASU1(3),?115,ASU1(4)
+9 ;
+10 ;Hdr2
+11 WRITE !,ASU2(1),?5,ASU2(2),?48,ASU2(3),?69,ASU2(4),?74,ASU2(5),?79,ASU2(6),?82,ASU2(7),?103,ASU2(8),?118,ASU2(9)
+12 ;
+13 ;Hdr 3
+14 WRITE !,ASU3(1),?4,ASU3(2),?12,ASU3(3),?44,ASU3(4),?48,ASU3(5),?69,ASU3(6),?74,ASU3(7),?79,ASU3(8),?85,ASU3(9),?94,ASU3(10),?104,ASU3(11),?118,ASU3(12)
+15 ;
+16 WRITE !,ASUR("LN")
+17 WRITE !
+18 QUIT
SETDATA ;Set DATA line
+1 ;SLC-Storage location code
SET ASURDL(1)=$PIECE(ASUR("DTA"),U)
+2 ;IDX-index number grouped as 5-1
SET ASURDL(2)=$PIECE(ASUR("DTA"),U,2)
+3 ;DSC1-Description 1
SET ASURDL(3)=$PIECE(ASUR("DTA"),U,3)
+4 ;AUI-Area Unit of issue
SET ASURDL(4)=$PIECE(ASUR("DTA"),U,5)
+5 ;VON-Vendor order number
SET ASUR=$PIECE(ASUR("DTA"),U,6)
SET ASURDL(5)=$$ON(ASUR)
+6 ;SRC-Source code
SET ASURDL(6)=$PIECE(ASUR("DTA"),U,8)
+7 ;LTM-Lead Time Months
SET ASURDL(7)=$PIECE(ASUR("DTA"),U,9)
+8 ;TC-Type Code
SET ASURDL(8)=$PIECE(ASUR("DTA"),U,10)
+9 ;LPP-Last Purchase Price
SET ASURDL(9)=$PIECE(ASUR("DTA"),U,11)
+10 ;PAMIQ-Projected Average Mon Iss Qnt
SET ASURDL(10)=$PIECE(ASUR("DTA"),U,12)
+11 ;P12MU-Prev 12 Months Issue Qnt
SET ASURDL(11)=$PIECE(ASUR("DTA"),U,13)
+12 ;PAIV-Projected Annual Issue Value
SET ASURDL(12)=$PIECE(ASUR("DTA"),U,14)
+13 ;DSC2-Description 2
SET ASURDL(13)=$PIECE(ASUR("DTA"),U,4)
+14 ;NSN-National Stock Number
SET ASURDL(14)=$PIECE(ASUR("DTA"),U,7)
+15 ;
+16 IF '$DATA(ASURVSCS(ASURDL(6)))
SET ASURVSCS(ASURDL(6))=""
+17 SET $PIECE(ASURVSCS(ASURDL(6)),U)=$PIECE(ASURVSCS(ASURDL(6)),U)+ASURDL(12)
SET $PIECE(ASURVSCS(ASURDL(6)),U,2)=$PIECE(ASURVSCS(ASURDL(6)),U,2)+1
+18 IF '$DATA(ASURVSCT(ASURDL(6)))
SET ASURVSCT(ASURDL(6))=""
+19 SET $PIECE(ASURVSCT(ASURDL(6)),U)=$PIECE(ASURVSCT(ASURDL(6)),U)+ASURDL(12)
SET $PIECE(ASURVSCT(ASURDL(6)),U,2)=$PIECE(ASURVSCT(ASURDL(6)),U,2)+1
+20 IF '$DATA(ASURVSCA(ASURDL(6)))
SET ASURVSCA(ASURDL(6))=""
+21 SET $PIECE(ASURVSCA(ASURDL(6)),U)=$PIECE(ASURVSCA(ASURDL(6)),U)+ASURDL(12)
SET $PIECE(ASURVSCA(ASURDL(6)),U,2)=$PIECE(ASURVSCA(ASURDL(6)),U,2)+1
+22 ;Print data line
+23 WRITE !
DO NEWPAGE
DO OUT(.ASURDL)
+24 QUIT
+25 ;
OUT(X) ;Print Data line
+1 ;Formal Parameter is X(1-14)
+2 ;Actual Parameter is ASURDL(1-14)
+3 WRITE X(1)
+4 WRITE ?3,X(2)
+5 WRITE ?12,X(3)
+6 WRITE ?44,X(4)
+7 WRITE ?48,X(5)
+8 WRITE ?69,X(6)
+9 WRITE ?74,X(7)
+10 WRITE ?79,X(8)
+11 WRITE ?83,$JUSTIFY(X(9),7,2)
+12 WRITE ?94,$JUSTIFY(X(10),5)
+13 WRITE ?103,$JUSTIFY(X(11),6)
+14 WRITE ?114,$JUSTIFY($FNUMBER(X(12),","),9)
+15 WRITE !
DO NEWPAGE
+16 WRITE ?12,X(13)
+17 QUIT
+18 ;
ON(X) ;EP; -Set VENDOR ORDER NUMBER -EXTRINSIC
+1 ;Set X into requested print format
+2 ;Actual parameter is ASUR
+3 ;Formal parameter is X
+4 ;If X]"" print as follows:
+5 ; $E(X)="M" ....Print as stored
+6 ; "M" ....4-2-3-5 grouping
+7 ;If X="" print as follows:
+8 ; ASURDL(14) ....4-2-3-5 grouping
+9 IF X]""
IF $EXTRACT(X)="M"
QUIT X
+10 IF X]""
SET X=$EXTRACT(X,1,4)_"-"_$EXTRACT(X,5,6)_"-"_$EXTRACT(X,7,9)_"-"_$EXTRACT(X,10,9999)
QUIT X
+11 SET X=ASURDL(14)
SET X=$EXTRACT(X,1,4)_"-"_$EXTRACT(X,5,6)_"-"_$EXTRACT(X,7,9)_"-"_$EXTRACT(X,10,999)
QUIT X
+12 QUIT
