- ASURQ25P ; IHS/ITSC/LMH -RPT 25 R & N ITEMS ;
- ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
- ;This routine formats and prints report 25, List R & N Items
- ;from sorted extracts.
- EN ;EP;PRIMARY ENTRY POINT FOR REPORT 25
- I '$D(IO) D HOME^%ZIS
- 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^ASUD25P",ZTDESC="SAMS RPT 25" 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:'$D(^XTMP("ASUR","R25")) SORT
- D U^ASUUZIS
- S (ASUC("PG"),ASUMS("E#","STA"))=0,ASUF("BK")=0
- S ASUV("E#","STA")=$O(^XTMP("ASUR","R25",0)) D:$G(ASUV("E#","STA"))]"" ARE^ASULARST($E(ASUV("E#","STA"),1,2)),STA^ASULARST(ASUV("E#","STA"))
- S ASUV("RPT")="R25",ASUQ("HDR")="HEADER^ASURQ25P"
- D ^ASUUDATA I ASUX("NDTA") G K
- S (ASUC("PG"),ASUMS("E#","STA"))=0,ASUF("BK")=""
- F S ASUMS("E#","STA")=$O(^XTMP("ASUR","R25",ASUMS("E#","STA"))) Q:ASUMS("E#","STA")']"" D Q:$D(DTOUT) Q:$D(DUOUT)
- .D ARE^ASULARST($E(ASUMS("E#","STA"),1,2)),STA^ASULARST(ASUMS("E#","STA"))
- .I ASUV("E#","STA")'=ASUMS("E#","STA") D HEADER S ASUV("E#","STA")=ASUMS("E#","STA")
- .S ASUMS("E#","IDX")=0,ASUMS("E#","ARE")=$E(ASUMS("E#","STA"),1,2)
- .F S ASUMS("E#","IDX")=$O(^XTMP("ASUR","R25",ASUMS("E#","STA"),ASUMS("E#","IDX"))) Q:ASUMS("E#","IDX")']"" D Q:$D(DUOUT) Q:$D(DTOUT)
- ..S ASUMX("E#","IDX")=ASUMS("E#","IDX")
- ..D READ^ASUMXDIO,^ASUMSTRD D:ASUF("BK") HEADER Q:$D(DUOUT) Q:$D(DTOUT)
- ..W !,ASUMX("CAT"),?5,$E(ASUMX("IDX"),1,5),".",$E(ASUMX("IDX"),6),?12,?15,ASUMX("DESC",1),?48,ASUMX("AR U/I"),?52,$J($FN(ASUMS("QTY","O/H"),","),8),?60,$J($FN(ASUMS("CST/U"),",",2),8)
- ..W !?15,ASUMX("DESC",2),! S ASUC("LINE")=$G(ASUC("LINE"))+3 D:ASUC("LINE")>IOSL HEADER
- ..S ASUC("LI")=$G(ASUC("LI"))+1
- .W !!?10,"STATION LINE ITEMS: ",ASUC("LI") S ASUC("TOTLI")=$G(ASUC("TOTLI"))+ASUC("LI") S ASUC("LI")=0
- .I $E(ASUMS("E#","STA"),1,2)'=ASUMS("E#","ARE") W !!,"AREA LINE ITEMS: ",ASUC("TOTLI") S ASUC("TOTLI")=0
- W !!,"AREA LINE ITEMS: ",ASUC("TOTLI") S ASUC("TOTLI")=0
- K ;
- K ASUMX,ASUMS,ASURX,ASUX,ASUC,ASUF("BK")
- Q
- S ASUC("PG")=$G(ASUC("PG"))+1,ASUC("LINE")=5
- I ASUC("PG")>1 D PAZ^ASUURHDR Q:$D(DUOUT) Q:$D(DTOUT)
- W @(IOF),"REPORT #25 PHARMACY QUARTERLY LIST OF R AND N ITEMS",?90,ASUK("DT"),?110,"PAGE",?115,$J($FN(ASUC("PG"),","),7)
- W !,"AREA",?6,ASUL(1,"AR","AP"),?9,ASUL(1,"AR","NM")
- W !,"STAT",?6,ASUL(2,"STA","CD"),?9,ASUL(2,"STA","NM")
- W !,"P INDEX",?54,"RECORD UNIT WHSE REC/ ADJ OVERAGES SHORTAGES"
- W !,"C NUMBER",?15,"DESCRIPTION",?47,"U/I",?53,"QUANTITY COST COUNT ISSUE QTY QTY VALUE QTY VALUE",!
- Q
- SORT ;
- K ^XTMP("ASUR","R25")
- S ^XTMP("ASUR","R25",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
- S ASUMS("E#","STA")=0,^XTMP("ASUR","R25",0)=ASUK("DT","FM")
- F S ASUMS("E#","STA")=$O(^ASUMS(ASUMS("E#","STA"))) Q:ASUMS("E#","STA")'?1N.N D
- .F ASUMS("E#","IDX")=0:0 S ASUMS("E#","IDX")=$O(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX"))) Q:ASUMS("E#","IDX")'?1N.N D
- ..D ^ASUMSTRD
- ..S ASUMX("E#","IDX")=ASUMS("E#","IDX") D READ^ASUMXDIO
- ..Q:ASUMX("ACC")'=1 Q:$G(ASUMX("DLIDX"))=1
- ..I (ASUMX("CAT")'="N")&(ASUMX("CAT")'="R") Q
- ..S ^XTMP("ASUR","R25",ASUMS("E#","STA"),ASUMS("E#","IDX"))=""
- Q
- ASURQ25P ; IHS/ITSC/LMH -RPT 25 R & N ITEMS ;
- +1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
- +2 ;This routine formats and prints report 25, List R & N Items
- +3 ;from sorted extracts.
- EN ;EP;PRIMARY ENTRY POINT FOR REPORT 25
- +1 IF '$DATA(IO)
- DO HOME^%ZIS
- +2 IF '$DATA(DUZ(2))
- WRITE !,"Report must be run from Kernel option"
- QUIT
- +3 IF '$DATA(ASUL(1,"AR","AP"))
- DO SETAREA^ASULARST
- +4 SET ASUK("PTRSEL")=$GET(ASUK("PTRSEL"))
- IF ASUK("PTRSEL")]""
- GOTO PSER
- +5 SET ZTRTN="PSER^ASUD25P"
- SET ZTDESC="SAMS RPT 25"
- DO O^ASUUZIS
- +6 IF POP
- SET IOP=$IO
- DO ^%ZIS
- QUIT
- +7 IF ASUK(ASUK("PTR"),"Q")
- QUIT
- PSER ;EP;FOR TASKMAN QUEUE OF PRINT
- +1 IF '$DATA(^XTMP("ASUR","R25"))
- DO SORT
- +2 DO U^ASUUZIS
- +3 SET (ASUC("PG"),ASUMS("E#","STA"))=0
- SET ASUF("BK")=0
- +4 SET ASUV("E#","STA")=$ORDER(^XTMP("ASUR","R25",0))
- IF $GET(ASUV("E#","STA"))]""
- DO ARE^ASULARST($EXTRACT(ASUV("E#","STA"),1,2))
- DO STA^ASULARST(ASUV("E#","STA"))
- +5 SET ASUV("RPT")="R25"
- SET ASUQ("HDR")="HEADER^ASURQ25P"
- +6 DO ^ASUUDATA
- IF ASUX("NDTA")
- GOTO K
- +7 SET (ASUC("PG"),ASUMS("E#","STA"))=0
- SET ASUF("BK")=""
- +8 FOR
- SET ASUMS("E#","STA")=$ORDER(^XTMP("ASUR","R25",ASUMS("E#","STA")))
- IF ASUMS("E#","STA")']""
- QUIT
- Begin DoDot:1
- +9 DO ARE^ASULARST($EXTRACT(ASUMS("E#","STA"),1,2))
- DO STA^ASULARST(ASUMS("E#","STA"))
- +10 IF ASUV("E#","STA")'=ASUMS("E#","STA")
- DO HEADER
- SET ASUV("E#","STA")=ASUMS("E#","STA")
- +11 SET ASUMS("E#","IDX")=0
- SET ASUMS("E#","ARE")=$EXTRACT(ASUMS("E#","STA"),1,2)
- +12 FOR
- SET ASUMS("E#","IDX")=$ORDER(^XTMP("ASUR","R25",ASUMS("E#","STA"),ASUMS("E#","IDX")))
- IF ASUMS("E#","IDX")']""
- QUIT
- Begin DoDot:2
- +13 SET ASUMX("E#","IDX")=ASUMS("E#","IDX")
- +14 DO READ^ASUMXDIO
- DO ^ASUMSTRD
- IF ASUF("BK")
- DO HEADER
- IF $DATA(DUOUT)
- QUIT
- IF $DATA(DTOUT)
- QUIT
- +15 WRITE !,ASUMX("CAT"),?5,$EXTRACT(ASUMX("IDX"),1,5),".",$EXTRACT(ASUMX("IDX"),6),?12,?15,ASUMX("DESC",1),?48,ASUMX("AR U/I"),?52,$JUSTIFY($FNUMBER(ASUMS("QTY","O/H"),","),8),?60,$JUSTIFY($FNUMBER(ASUMS("CST/U"),",",2),8)
- +16 WRITE !?15,ASUMX("DESC",2),!
- SET ASUC("LINE")=$GET(ASUC("LINE"))+3
- IF ASUC("LINE")>IOSL
- DO HEADER
- +17 SET ASUC("LI")=$GET(ASUC("LI"))+1
- End DoDot:2
- IF $DATA(DUOUT)
- QUIT
- IF $DATA(DTOUT)
- QUIT
- +18 WRITE !!?10,"STATION LINE ITEMS: ",ASUC("LI")
- SET ASUC("TOTLI")=$GET(ASUC("TOTLI"))+ASUC("LI")
- SET ASUC("LI")=0
- +19 IF $EXTRACT(ASUMS("E#","STA"),1,2)'=ASUMS("E#","ARE")
- WRITE !!,"AREA LINE ITEMS: ",ASUC("TOTLI")
- SET ASUC("TOTLI")=0
- End DoDot:1
- IF $DATA(DTOUT)
- QUIT
- IF $DATA(DUOUT)
- QUIT
- +20 WRITE !!,"AREA LINE ITEMS: ",ASUC("TOTLI")
- SET ASUC("TOTLI")=0
- K ;
- +1 KILL ASUMX,ASUMS,ASURX,ASUX,ASUC,ASUF("BK")
- +2 QUIT
- +1 SET ASUC("PG")=$GET(ASUC("PG"))+1
- SET ASUC("LINE")=5
- +2 IF ASUC("PG")>1
- DO PAZ^ASUURHDR
- IF $DATA(DUOUT)
- QUIT
- IF $DATA(DTOUT)
- QUIT
- +3 WRITE @(IOF),"REPORT #25 PHARMACY QUARTERLY LIST OF R AND N ITEMS",?90,ASUK("DT"),?110,"PAGE",?115,$JUSTIFY($FNUMBER(ASUC("PG"),","),7)
- +4 WRITE !,"AREA",?6,ASUL(1,"AR","AP"),?9,ASUL(1,"AR","NM")
- +5 WRITE !,"STAT",?6,ASUL(2,"STA","CD"),?9,ASUL(2,"STA","NM")
- +6 WRITE !,"P INDEX",?54,"RECORD UNIT WHSE REC/ ADJ OVERAGES SHORTAGES"
- +7 WRITE !,"C NUMBER",?15,"DESCRIPTION",?47,"U/I",?53,"QUANTITY COST COUNT ISSUE QTY QTY VALUE QTY VALUE",!
- +8 QUIT
- SORT ;
- +1 KILL ^XTMP("ASUR","R25")
- +2 SET ^XTMP("ASUR","R25",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
- +3 SET ASUMS("E#","STA")=0
- SET ^XTMP("ASUR","R25",0)=ASUK("DT","FM")
- +4 FOR
- SET ASUMS("E#","STA")=$ORDER(^ASUMS(ASUMS("E#","STA")))
- IF ASUMS("E#","STA")'?1N.N
- QUIT
- Begin DoDot:1
- +5 FOR ASUMS("E#","IDX")=0:0
- SET ASUMS("E#","IDX")=$ORDER(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX")))
- IF ASUMS("E#","IDX")'?1N.N
- QUIT
- Begin DoDot:2
- +6 DO ^ASUMSTRD
- +7 SET ASUMX("E#","IDX")=ASUMS("E#","IDX")
- DO READ^ASUMXDIO
- +8 IF ASUMX("ACC")'=1
- QUIT
- IF $GET(ASUMX("DLIDX"))=1
- QUIT
- +9 IF (ASUMX("CAT")'="N")&(ASUMX("CAT")'="R")
- QUIT
- +10 SET ^XTMP("ASUR","R25",ASUMS("E#","STA"),ASUMS("E#","IDX"))=""
- End DoDot:2
- End DoDot:1
- +11 QUIT
