- PRCPLO ;WOIFO/RLL/VAC/DAP-days of stock on hand report ; 2/26/07 1:53pm
- ;;5.1;IFCAP;**83,98**;Oct 20, 2000;Build 37
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ; Note: This routine was copied from PRCPRSOH
- ;*98 Code modification made to handle STD and ODI breakouts
- ;
- Q
- ENT ; Entry Point to run Program
- L +^PRCP(446.7,"STATUS"):3 I $T=0 S PRCPMSG(1)="Error encountered when attempting to run CLO GIP Reports due to other CLRS extracts in progress, please try again later." D MAIL^PRCPLO3 Q
- N TOSTDCNT,TOODICNT,TOALLCNT,TOTCNT,VALUES
- D PRCPRINV ; Run the logic from PRCPRSOH, get params
- D BLDFIL ; Build the output data
- D GETVAL ; Set the ^DIE Entries in 446.7
- L -^PRCP(446.7,"STATUS")
- ;
- K ^TMP($J,"PRCPSOH") ;kill off tmp data
- K ^TMP($J,"PRCPLO") ;kill off tmp data
- K ^TMP($J,"PRCPSOH2") ; kill off ODI tmp data
- K ^TMP($J,"PRCPLO2") ;kill off ODI tmp data
- Q
- ;
- ;
- PRCPRINV ; run INV Point
- N CLRSFLAG
- S CLRSFLAG="SOH"
- D GETIPT^PRCPLO1
- Q
- EN1 ; Added return from PRCPLO1
- ; Q
- N DATEEND,DATEENDD,DATESTRD,DATESTRT,DAYSLEFT,DIR,GROUPALL,PRCPDAYS,PRCPEND,PRCPSTRT,PRCPTYPE,TOTALDAY,X,X1,X2,Y,MNT,TODAY
- N ODICNT,ODIDOL,ODIFLAG,ODIFLG,STDCNT,STDDOL
- ;
- ; *83 The following was edited to always enter the LAST DAY
- ; of the previous month as the end date. End date for Oct 31, 2005
- ; in FM 3051031, can also use 3051100 equivalent for date sort
- ; this way, you do not have to handle months w/ 28, 29, 30 or 31 days
- D NOW^%DTC S TODAY=X,Y=$E(X,1,3),MNT=$E(X,4,5)
- S MNT=+(MNT)
- S MNT=MNT-1
- I MNT=0 S MNT=12,Y=Y-1
- I $L(MNT)=1 S MNT=0_MNT
- ;
- ; *83 Added day logic to handle month/leap year, etc.
- N DAYS,CKF
- S DAYS=$P("31^28^31^30^31^30^31^31^30^31^30^31",U,+(MNT))
- S DATEEND=Y_MNT_DAYS
- I DAYS=28 D
- . S CKF=(17+$E(DATEEND))_$E(DATEEND,2,3)
- . S DAYS=$S(CKF#400=0:29,(CKF#4=0&(CKF#100'=0)):29,1:28)
- . S DATEEND=Y_MNT_DAYS
- . Q
- ; S DATEEND=Y_MNT_"00"
- ; *83 The following was edited to always enter a 90 day previous
- ; to current date of report run (check param file, could change)
- ; for the DATESTRT. Once DATEEND and DATESTRT are determined, we
- ; can use the existing code to set the other variables
- S X1=TODAY
- ; *83 Report range supplied by site parameter and defaulted to 180
- S X2=$$GET^XPAR("SYS","PRCPLO REPORT RANGE",1,"Q")
- I X2="" S X2=180
- S X2=(X2*-1)
- D C^%DTC S DATESTRT=$E(X,1,5)_"01"
- ; DATEEND and DATESTRT are set above, pass them to existing
- ; logic below to set remaining variables
- S X1=DATEEND,X2=DATESTRT D ^%DTC S TOTALDAY=X+1
- S Y=DATEEND D DD^%DT S DATEENDD=Y,Y=DATESTRT D DD^%DT S DATESTRD=Y
- ;
- ;*83 Set PRCPTYPE=2 (always GREATER)
- S PRCPTYPE=2
- ;
- ;*83 PRCPDAYS is set based on value of CLRS GREATER THAN RANGE parameter
- ;if no value is presented in the parameter, it will default to 90
- ;
- S PRCPDAYS=$$GET^XPAR("SYS","PRCPLO GREATER THAN RANGE",1,"Q")
- I PRCPDAYS="" S PRCPDAYS=90
- ;
- ;*83 Return PRCPSTRT="" and PRCPEND=""
- I PRCP("DPTYPE")="W" D
- . S PRCPSTRT="",PRCPEND=""
- ;
- ;*83 RETURN GROUPALL=1 to select all groups
- I PRCP("DPTYPE")'="W" D
- . S GROUPALL=1
- . ; finished adding variables
- ;
- DQ ; queue starts here
- N AVERAGE,DATE,GROUP,GROUPNM,ITEMDA,ITEMDATA,NSN,ONHAND,TOTAL,X,Y
- K ^TMP($J,"PRCPRSOH")
- S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA S ITEMDATA=$G(^(ITEMDA,0)) I ITEMDATA'="" D
- . S ODIFLG=1 S ODIFLAG=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
- . I ODIFLAG="Y" S ODIFLG=2
- . S TOTCNT(PRCP("I"),ODIFLG)=+$G(TOTCNT(PRCP("I"),ODIFLG))+1
- . I $$REUSABLE^PRCPU441(ITEMDA) Q
- . ; calculate total usage between dates
- . S DATE=$E(DATESTRT,1,5)-.01,TOTAL=0 F S DATE=$O(^PRCP(445,PRCP("I"),1,ITEMDA,2,DATE)) Q:'DATE!(DATE>$E(DATEEND,1,5)) S TOTAL=TOTAL+$P($G(^(DATE,0)),"^",2)
- . S AVERAGE=$J(TOTAL/TOTALDAY,0,2),ONHAND=$P(ITEMDATA,"^",7)+$P(ITEMDATA,"^",19)
- . S DAYSLEFT=$S('AVERAGE&(ONHAND):9999999,'AVERAGE:0,1:ONHAND/AVERAGE\1)
- . I PRCPTYPE=1,DAYSLEFT'<PRCPDAYS Q
- . I PRCPTYPE=2,DAYSLEFT'>PRCPDAYS Q
- . ; sort for whse
- . I PRCP("DPTYPE")="W" D Q
- . . S NSN=$$NSN^PRCPUX1(ITEMDA) S:NSN="" NSN=" "
- . . I $E(NSN,1,$L(PRCPSTRT))'=PRCPSTRT,$E(NSN,1,$L(PRCPEND))'=PRCPEND I NSN']PRCPSTRT!(PRCPEND']NSN) Q
- . . ; S ^TMP($J,"PRCPRSOH",NSN,ITEMDA)=TOTAL_"^"_AVERAGE_"^"_ONHAND_"^"_$P(DAYSLEFT,".")_"^"_$P(ITEMDATA,"^",27)
- . . N ITMCHK
- . . S ITMCHK=0,ITMCHK=$O(^PRCP(445,PRCP("I"),1,ITMCHK))
- . . Q:ITMCHK=""!(+(ITMCHK)<1)
- . . Q:+(ITMCHK)<1 ; made it to x-ref
- . . D BLDTMP
- . ;98* Accumulate count information
- . S VALUES(PRCP("I"),ODIFLG)=+$G(VALUES(PRCP("I"),ODIFLG))+1
- . ; sort for primary and secondary
- . S GROUP=+$P(ITEMDATA,"^",21)
- . I 'GROUP,'$G(GROUPALL) Q
- . I $G(GROUPALL),$D(^TMP($J,"PRCPURS1","NO",GROUP)) Q
- . I '$G(GROUPALL),'$D(^TMP($J,"PRCPURS1","YES",GROUP)) Q
- . S GROUPNM=$$GROUPNM^PRCPEGRP(GROUP)
- . I GROUPNM'="" S GROUPNM=$E(GROUPNM,1,20)_" (#"_GROUP_")"
- . S:GROUPNM="" GROUPNM=" "
- . ;*83, Create TMP structure for Report
- . N ITMCHK
- . S ITMCHK=0,ITMCHK=$O(^PRCP(445,PRCP("I"),1,ITMCHK))
- . Q:ITMCHK=""!(+(ITMCHK)<1)
- . Q:ITMCHK<1 ; made it to x-ref
- . D BLDTMP
- . Q
- Q
- ;
- BLDTMP ;*83 Build ^TMP Structure for Report Server
- ;
- N INVTYPE,ITEMDESC,CSTCTR,INDAT,NUMLNIT,DATRN,DATRN1,INVPTID
- N CSTC1,CSTC2,CSTC3,CSCE1,CSCE2,V4TR,V4TR1
- ;
- S DATRN=$$FMTE^XLFDT(+DATEEND)
- S DATRN1=$P(DATRN," ",1)_","_$P(DATRN," ",3)
- S ITEMDESC=$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,15) ; item Desc
- I ITEMDESC="" S ITEMDESC="No Item Desc"
- Q:ITEMDA=""!(+(ITEMDA)<1)
- ;
- S NUMLNIT=1 ; set to 1 for each line item.
- S INVTYPE=PRCP("DPTYPE")
- I INVTYPE="" S INVTYPE="No Inv Type"
- S INDAT=$G(PRCP("PAR"))
- S INVPTID=PRCP("I") ; inv point id #
- ; Cost Center logic
- ; Get ^PRCP(445,INVPTID,0) 7th piece (int. Cost Center #)
- ; Get ^PRCD(420.1,IntCstCtr,0) 1st piece (external format)
- S CSTC1=$G(^PRCP(445,INVPTID,0)),CSTC2=$P(CSTC1,"^",7),CSTC3=$P(CSTC1,"^",3)
- S V4TR=$P(CSTC1,"^",1),V4TR1=$P(V4TR,"-",2,99) ; *83 look up name
- S V4TR1=$TR(V4TR1,"*","|") ; $TR name to replace "*"'s with "|"'s
- I CSTC2'="" S CSCE1=$G(^PRCD(420.1,CSTC2,0)),CSCE2=$P(CSCE1,"^",1)
- I CSTC2="" S CSCE2="No Cost Center"
- ; *83, Set 5th Node from ITEMDESC to ITEMDA
- S ^TMP($J,"PRCPLO",V3,INVPTID,ITEMDA)=V3_"*"_DATRN1_"*"_INVPTID_"*"_V4TR1_"*"_NUMLNIT_"*"_$P(ITEMDATA,"^",27)_"*"_CSCE2_"*"_INVTYPE
- ; *98 Split information for ODI and Standard
- S ^TMP($J,"PRCPLO2",V3,INVPTID,ITEMDA,ODIFLG)=+$G(^TMP($J,"PRCPLO2",V3,INVPTID,ITEMDA,ODIFLG))+$P(ITEMDATA,"^",27)
- Q
- BLDFIL ; Build output file
- N IN1,IN2,IN3,IN4,IN5,OLPV,NWPV,INDDAT,TOTDOL,LNDOL,CSTCTR,LNCT,PRCPDX,INPTVAL,POINT,STID,DTTM,INVVTYP,INVPTLN
- S IN1=0,IN2=0,IN3=0,IN4=0,IN5="INVPT",INDDAT=0,OLPV=0,NWPV=0,LNCT=0,CSTCTR=0,TOTDOL=0,LNDOL=0,INVPTLN=0
- S STDCNT=0,ODICNT=0
- S (STDDOL,ODIDOL)=0
- F S IN1=$O(^TMP($J,"PRCPLO",IN1)) Q:IN1="" D
- . ;S (STDDOL,ODIDOL)=0
- . F S IN2=$O(^TMP($J,"PRCPLO",IN1,IN2)) Q:IN2="" D
- . . I IN5'="INVPT" D ; init for first time through
- . . . S INVPTLN=+$P($G(^PRCP(445,+INPTVAL,1,0)),"^",4)
- . . . S TOSTDCNT=+$G(TOTCNT(IN2,1)),TOODICNT=+$G(TOTCNT(IN2,2)),TOALLCNT=TOSTDCNT+TOODICNT
- . . . S PRCPDX=STID_"*"_DTTM_"*"_INPTVAL_"*"_POINT_"*"_INVVTYP_"*"_TOTDOL_"*"_IN4_"*"_INVPTLN_"*"_CSTCTR
- . . . ; set up new ^TMP($J NODE to store totals for ^DIE set
- . . . S ^TMP($J,"PRCPSOH",+(STID_INPTVAL))=PRCPDX
- . . . S STDCNT=+$G(VALUES(INPTVAL,1)),ODICNT=+$G(VALUES(INPTVAL,2))
- . . . S TOSTDCNT=+$G(TOTCNT(INPTVAL,1)),TOODICNT=+$G(TOTCNT(INPTVAL,2))
- . . . S TOALLCNT=TOSTDCNT+TOODICNT
- . . . S ^TMP($J,"PRCPSOH2",+(STID_INPTVAL))=STDDOL_"*"_ODIDOL_"*"_(STDDOL+ODIDOL)_"*"_STDCNT_"*"_ODICNT_"*"_(STDCNT+ODICNT)_"*"_TOSTDCNT_"*"_TOODICNT_"*"_TOALLCNT
- . . . S IN4=0 ; reset to 0, begin counting Line items for INVPT
- . . . S TOTDOL=0
- . . . S LNDOL=0
- . . . S PRCPDX=""
- . . . S CSTCTR=""
- . . . S (STDDOL,ODIDOL)=0
- . . F S IN3=$O(^TMP($J,"PRCPLO",IN1,IN2,IN3)) Q:IN3="" D
- . . . S INDDAT=$G(^TMP($J,"PRCPLO",IN1,IN2,IN3))
- . . . S STID=$P(INDDAT,"*",1)
- . . . S DTTM=$P(INDDAT,"*",2)
- . . . S POINT=$P(INDDAT,"*",4)
- . . . S INPTVAL=$P(INDDAT,"*",3) ; Inv Point ID# for DIE Set
- . . . S CSTCTR=$P(INDDAT,"*",7)
- . . . S LNDOL=$P(INDDAT,"*",6)
- . . . S INVVTYP=$P(INDDAT,"*",8)
- . . . S TOTDOL=TOTDOL+LNDOL
- . . . S IN4=IN4+1 ; Count # of line items in Inv Pt
- . . . S IN5=IN2 ; Invt. Point
- . . . S STDDOL=STDDOL+$G(^TMP($J,"PRCPLO2",IN1,IN2,IN3,1))
- . . . S ODIDOL=ODIDOL+$G(^TMP($J,"PRCPLO2",IN1,IN2,IN3,2))
- . . . Q
- . . Q
- . Q
- Q
- GETVAL ; Get values from ^TMP($J,"PRCPSOH"
- N LP1,SOHIEN,PRCPDX
- S LP1=0
- F S LP1=$O(^TMP($J,"PRCPSOH",LP1)) Q:LP1="" D
- . S PRCPDX=$G(^TMP($J,"PRCPSOH",LP1))
- . S SOHIEN=+LP1
- . S DR="1///"_PRCPDX
- . D SETREC
- . S PRCPDX=$G(^TMP($J,"PRCPSOH2",LP1))
- . S DR="2///"_PRCPDX
- . D SETREC
- . Q
- Q
- SETREC ; Set record using DIE in 446.7
- ;
- N PRCPDR,PRCPST,PRCPSNM,PRCPDA,PRCPDX,PRCPST,X,Y
- S PRCPDR=DR
- S DIC="^PRCP(446.7,",DIC(0)="L",DLAYGO=446.7,X=SOHIEN D ^DIC K DIC,DLAYGO
- S PRCPDA=Y+0
- S PRCPST=$P(^TMP($J,"PRCPSOH",LP1),"*",1)
- S PRCPSNM=$$GET1^DIQ(4,PRCPST_",",.01)
- ;*98 Send enhanced mail message if exception occurs during FileMan set
- I Y=-1 N PRCPMSG D Q
- . S PRCPMSG(1)="Error saving to File #446.7 for Days of Stock on Hand Report, related data: "
- . S PRCPMSG(2)="",PRCPMSG(3)="Station: "_PRCPST_" "_PRCPSNM
- . S PRCPMSG(4)="Inventory Point: "_$P(^TMP($J,"PRCPSOH",LP1),"*",3)_" "_$P(^TMP($J,"PRCPSOH",LP1),"*",4)
- . S PRCPMSG(5)="File #446.7 Field Set Attempted: "_PRCPDR
- . D MAIL^PRCPLO3 Q
- ;
- S DIE="^PRCP(446.7,",DA=PRCPDA D ^DIE K DIE,DR,DA
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPLO 9741 printed Mar 13, 2025@21:18:50 Page 2
- PRCPLO ;WOIFO/RLL/VAC/DAP-days of stock on hand report ; 2/26/07 1:53pm
- +1 ;;5.1;IFCAP;**83,98**;Oct 20, 2000;Build 37
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ; Note: This routine was copied from PRCPRSOH
- +4 ;*98 Code modification made to handle STD and ODI breakouts
- +5 ;
- +6 QUIT
- ENT ; Entry Point to run Program
- +1 LOCK +^PRCP(446.7,"STATUS"):3
- IF $TEST=0
- SET PRCPMSG(1)="Error encountered when attempting to run CLO GIP Reports due to other CLRS extracts in progress, please try again later."
- DO MAIL^PRCPLO3
- QUIT
- +2 NEW TOSTDCNT,TOODICNT,TOALLCNT,TOTCNT,VALUES
- +3 ; Run the logic from PRCPRSOH, get params
- DO PRCPRINV
- +4 ; Build the output data
- DO BLDFIL
- +5 ; Set the ^DIE Entries in 446.7
- DO GETVAL
- +6 LOCK -^PRCP(446.7,"STATUS")
- +7 ;
- +8 ;kill off tmp data
- KILL ^TMP($JOB,"PRCPSOH")
- +9 ;kill off tmp data
- KILL ^TMP($JOB,"PRCPLO")
- +10 ; kill off ODI tmp data
- KILL ^TMP($JOB,"PRCPSOH2")
- +11 ;kill off ODI tmp data
- KILL ^TMP($JOB,"PRCPLO2")
- +12 QUIT
- +13 ;
- +14 ;
- PRCPRINV ; run INV Point
- +1 NEW CLRSFLAG
- +2 SET CLRSFLAG="SOH"
- +3 DO GETIPT^PRCPLO1
- +4 QUIT
- EN1 ; Added return from PRCPLO1
- +1 ; Q
- +2 NEW DATEEND,DATEENDD,DATESTRD,DATESTRT,DAYSLEFT,DIR,GROUPALL,PRCPDAYS,PRCPEND,PRCPSTRT,PRCPTYPE,TOTALDAY,X,X1,X2,Y,MNT,TODAY
- +3 NEW ODICNT,ODIDOL,ODIFLAG,ODIFLG,STDCNT,STDDOL
- +4 ;
- +5 ; *83 The following was edited to always enter the LAST DAY
- +6 ; of the previous month as the end date. End date for Oct 31, 2005
- +7 ; in FM 3051031, can also use 3051100 equivalent for date sort
- +8 ; this way, you do not have to handle months w/ 28, 29, 30 or 31 days
- +9 DO NOW^%DTC
- SET TODAY=X
- SET Y=$EXTRACT(X,1,3)
- SET MNT=$EXTRACT(X,4,5)
- +10 SET MNT=+(MNT)
- +11 SET MNT=MNT-1
- +12 IF MNT=0
- SET MNT=12
- SET Y=Y-1
- +13 IF $LENGTH(MNT)=1
- SET MNT=0_MNT
- +14 ;
- +15 ; *83 Added day logic to handle month/leap year, etc.
- +16 NEW DAYS,CKF
- +17 SET DAYS=$PIECE("31^28^31^30^31^30^31^31^30^31^30^31",U,+(MNT))
- +18 SET DATEEND=Y_MNT_DAYS
- +19 IF DAYS=28
- Begin DoDot:1
- +20 SET CKF=(17+$EXTRACT(DATEEND))_$EXTRACT(DATEEND,2,3)
- +21 SET DAYS=$SELECT(CKF#400=0:29,(CKF#4=0&(CKF#100'=0)):29,1:28)
- +22 SET DATEEND=Y_MNT_DAYS
- +23 QUIT
- End DoDot:1
- +24 ; S DATEEND=Y_MNT_"00"
- +25 ; *83 The following was edited to always enter a 90 day previous
- +26 ; to current date of report run (check param file, could change)
- +27 ; for the DATESTRT. Once DATEEND and DATESTRT are determined, we
- +28 ; can use the existing code to set the other variables
- +29 SET X1=TODAY
- +30 ; *83 Report range supplied by site parameter and defaulted to 180
- +31 SET X2=$$GET^XPAR("SYS","PRCPLO REPORT RANGE",1,"Q")
- +32 IF X2=""
- SET X2=180
- +33 SET X2=(X2*-1)
- +34 DO C^%DTC
- SET DATESTRT=$EXTRACT(X,1,5)_"01"
- +35 ; DATEEND and DATESTRT are set above, pass them to existing
- +36 ; logic below to set remaining variables
- +37 SET X1=DATEEND
- SET X2=DATESTRT
- DO ^%DTC
- SET TOTALDAY=X+1
- +38 SET Y=DATEEND
- DO DD^%DT
- SET DATEENDD=Y
- SET Y=DATESTRT
- DO DD^%DT
- SET DATESTRD=Y
- +39 ;
- +40 ;*83 Set PRCPTYPE=2 (always GREATER)
- +41 SET PRCPTYPE=2
- +42 ;
- +43 ;*83 PRCPDAYS is set based on value of CLRS GREATER THAN RANGE parameter
- +44 ;if no value is presented in the parameter, it will default to 90
- +45 ;
- +46 SET PRCPDAYS=$$GET^XPAR("SYS","PRCPLO GREATER THAN RANGE",1,"Q")
- +47 IF PRCPDAYS=""
- SET PRCPDAYS=90
- +48 ;
- +49 ;*83 Return PRCPSTRT="" and PRCPEND=""
- +50 IF PRCP("DPTYPE")="W"
- Begin DoDot:1
- +51 SET PRCPSTRT=""
- SET PRCPEND=""
- End DoDot:1
- +52 ;
- +53 ;*83 RETURN GROUPALL=1 to select all groups
- +54 IF PRCP("DPTYPE")'="W"
- Begin DoDot:1
- +55 SET GROUPALL=1
- +56 ; finished adding variables
- End DoDot:1
- +57 ;
- DQ ; queue starts here
- +1 NEW AVERAGE,DATE,GROUP,GROUPNM,ITEMDA,ITEMDATA,NSN,ONHAND,TOTAL,X,Y
- +2 KILL ^TMP($JOB,"PRCPRSOH")
- +3 SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
- if 'ITEMDA
- QUIT
- SET ITEMDATA=$GET(^(ITEMDA,0))
- IF ITEMDATA'=""
- Begin DoDot:1
- +4 SET ODIFLG=1
- SET ODIFLAG=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
- +5 IF ODIFLAG="Y"
- SET ODIFLG=2
- +6 SET TOTCNT(PRCP("I"),ODIFLG)=+$GET(TOTCNT(PRCP("I"),ODIFLG))+1
- +7 IF $$REUSABLE^PRCPU441(ITEMDA)
- QUIT
- +8 ; calculate total usage between dates
- +9 SET DATE=$EXTRACT(DATESTRT,1,5)-.01
- SET TOTAL=0
- FOR
- SET DATE=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,2,DATE))
- if 'DATE!(DATE>$EXTRACT(DATEEND,1,5))
- QUIT
- SET TOTAL=TOTAL+$PIECE($GET(^(DATE,0)),"^",2)
- +10 SET AVERAGE=$JUSTIFY(TOTAL/TOTALDAY,0,2)
- SET ONHAND=$PIECE(ITEMDATA,"^",7)+$PIECE(ITEMDATA,"^",19)
- +11 SET DAYSLEFT=$SELECT('AVERAGE&(ONHAND):9999999,'AVERAGE:0,1:ONHAND/AVERAGE\1)
- +12 IF PRCPTYPE=1
- IF DAYSLEFT'<PRCPDAYS
- QUIT
- +13 IF PRCPTYPE=2
- IF DAYSLEFT'>PRCPDAYS
- QUIT
- +14 ; sort for whse
- +15 IF PRCP("DPTYPE")="W"
- Begin DoDot:2
- +16 SET NSN=$$NSN^PRCPUX1(ITEMDA)
- if NSN=""
- SET NSN=" "
- +17 IF $EXTRACT(NSN,1,$LENGTH(PRCPSTRT))'=PRCPSTRT
- IF $EXTRACT(NSN,1,$LENGTH(PRCPEND))'=PRCPEND
- IF NSN']PRCPSTRT!(PRCPEND']NSN)
- QUIT
- +18 ; S ^TMP($J,"PRCPRSOH",NSN,ITEMDA)=TOTAL_"^"_AVERAGE_"^"_ONHAND_"^"_$P(DAYSLEFT,".")_"^"_$P(ITEMDATA,"^",27)
- +19 NEW ITMCHK
- +20 SET ITMCHK=0
- SET ITMCHK=$ORDER(^PRCP(445,PRCP("I"),1,ITMCHK))
- +21 if ITMCHK=""!(+(ITMCHK)<1)
- QUIT
- +22 ; made it to x-ref
- if +(ITMCHK)<1
- QUIT
- +23 DO BLDTMP
- End DoDot:2
- QUIT
- +24 ;98* Accumulate count information
- +25 SET VALUES(PRCP("I"),ODIFLG)=+$GET(VALUES(PRCP("I"),ODIFLG))+1
- +26 ; sort for primary and secondary
- +27 SET GROUP=+$PIECE(ITEMDATA,"^",21)
- +28 IF 'GROUP
- IF '$GET(GROUPALL)
- QUIT
- +29 IF $GET(GROUPALL)
- IF $DATA(^TMP($JOB,"PRCPURS1","NO",GROUP))
- QUIT
- +30 IF '$GET(GROUPALL)
- IF '$DATA(^TMP($JOB,"PRCPURS1","YES",GROUP))
- QUIT
- +31 SET GROUPNM=$$GROUPNM^PRCPEGRP(GROUP)
- +32 IF GROUPNM'=""
- SET GROUPNM=$EXTRACT(GROUPNM,1,20)_" (#"_GROUP_")"
- +33 if GROUPNM=""
- SET GROUPNM=" "
- +34 ;*83, Create TMP structure for Report
- +35 NEW ITMCHK
- +36 SET ITMCHK=0
- SET ITMCHK=$ORDER(^PRCP(445,PRCP("I"),1,ITMCHK))
- +37 if ITMCHK=""!(+(ITMCHK)<1)
- QUIT
- +38 ; made it to x-ref
- if ITMCHK<1
- QUIT
- +39 DO BLDTMP
- +40 QUIT
- End DoDot:1
- +41 QUIT
- +42 ;
- BLDTMP ;*83 Build ^TMP Structure for Report Server
- +1 ;
- +2 NEW INVTYPE,ITEMDESC,CSTCTR,INDAT,NUMLNIT,DATRN,DATRN1,INVPTID
- +3 NEW CSTC1,CSTC2,CSTC3,CSCE1,CSCE2,V4TR,V4TR1
- +4 ;
- +5 SET DATRN=$$FMTE^XLFDT(+DATEEND)
- +6 SET DATRN1=$PIECE(DATRN," ",1)_","_$PIECE(DATRN," ",3)
- +7 ; item Desc
- SET ITEMDESC=$EXTRACT($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,15)
- +8 IF ITEMDESC=""
- SET ITEMDESC="No Item Desc"
- +9 if ITEMDA=""!(+(ITEMDA)<1)
- QUIT
- +10 ;
- +11 ; set to 1 for each line item.
- SET NUMLNIT=1
- +12 SET INVTYPE=PRCP("DPTYPE")
- +13 IF INVTYPE=""
- SET INVTYPE="No Inv Type"
- +14 SET INDAT=$GET(PRCP("PAR"))
- +15 ; inv point id #
- SET INVPTID=PRCP("I")
- +16 ; Cost Center logic
- +17 ; Get ^PRCP(445,INVPTID,0) 7th piece (int. Cost Center #)
- +18 ; Get ^PRCD(420.1,IntCstCtr,0) 1st piece (external format)
- +19 SET CSTC1=$GET(^PRCP(445,INVPTID,0))
- SET CSTC2=$PIECE(CSTC1,"^",7)
- SET CSTC3=$PIECE(CSTC1,"^",3)
- +20 ; *83 look up name
- SET V4TR=$PIECE(CSTC1,"^",1)
- SET V4TR1=$PIECE(V4TR,"-",2,99)
- +21 ; $TR name to replace "*"'s with "|"'s
- SET V4TR1=$TRANSLATE(V4TR1,"*","|")
- +22 IF CSTC2'=""
- SET CSCE1=$GET(^PRCD(420.1,CSTC2,0))
- SET CSCE2=$PIECE(CSCE1,"^",1)
- +23 IF CSTC2=""
- SET CSCE2="No Cost Center"
- +24 ; *83, Set 5th Node from ITEMDESC to ITEMDA
- +25 SET ^TMP($JOB,"PRCPLO",V3,INVPTID,ITEMDA)=V3_"*"_DATRN1_"*"_INVPTID_"*"_V4TR1_"*"_NUMLNIT_"*"_$PIECE(ITEMDATA,"^",27)_"*"_CSCE2_"*"_INVTYPE
- +26 ; *98 Split information for ODI and Standard
- +27 SET ^TMP($JOB,"PRCPLO2",V3,INVPTID,ITEMDA,ODIFLG)=+$GET(^TMP($JOB,"PRCPLO2",V3,INVPTID,ITEMDA,ODIFLG))+$PIECE(ITEMDATA,"^",27)
- +28 QUIT
- BLDFIL ; Build output file
- +1 NEW IN1,IN2,IN3,IN4,IN5,OLPV,NWPV,INDDAT,TOTDOL,LNDOL,CSTCTR,LNCT,PRCPDX,INPTVAL,POINT,STID,DTTM,INVVTYP,INVPTLN
- +2 SET IN1=0
- SET IN2=0
- SET IN3=0
- SET IN4=0
- SET IN5="INVPT"
- SET INDDAT=0
- SET OLPV=0
- SET NWPV=0
- SET LNCT=0
- SET CSTCTR=0
- SET TOTDOL=0
- SET LNDOL=0
- SET INVPTLN=0
- +3 SET STDCNT=0
- SET ODICNT=0
- +4 SET (STDDOL,ODIDOL)=0
- +5 FOR
- SET IN1=$ORDER(^TMP($JOB,"PRCPLO",IN1))
- if IN1=""
- QUIT
- Begin DoDot:1
- +6 ;S (STDDOL,ODIDOL)=0
- +7 FOR
- SET IN2=$ORDER(^TMP($JOB,"PRCPLO",IN1,IN2))
- if IN2=""
- QUIT
- Begin DoDot:2
- +8 ; init for first time through
- IF IN5'="INVPT"
- Begin DoDot:3
- +9 SET INVPTLN=+$PIECE($GET(^PRCP(445,+INPTVAL,1,0)),"^",4)
- +10 SET TOSTDCNT=+$GET(TOTCNT(IN2,1))
- SET TOODICNT=+$GET(TOTCNT(IN2,2))
- SET TOALLCNT=TOSTDCNT+TOODICNT
- +11 SET PRCPDX=STID_"*"_DTTM_"*"_INPTVAL_"*"_POINT_"*"_INVVTYP_"*"_TOTDOL_"*"_IN4_"*"_INVPTLN_"*"_CSTCTR
- +12 ; set up new ^TMP($J NODE to store totals for ^DIE set
- +13 SET ^TMP($JOB,"PRCPSOH",+(STID_INPTVAL))=PRCPDX
- +14 SET STDCNT=+$GET(VALUES(INPTVAL,1))
- SET ODICNT=+$GET(VALUES(INPTVAL,2))
- +15 SET TOSTDCNT=+$GET(TOTCNT(INPTVAL,1))
- SET TOODICNT=+$GET(TOTCNT(INPTVAL,2))
- +16 SET TOALLCNT=TOSTDCNT+TOODICNT
- +17 SET ^TMP($JOB,"PRCPSOH2",+(STID_INPTVAL))=STDDOL_"*"_ODIDOL_"*"_(STDDOL+ODIDOL)_"*"_STDCNT_"*"_ODICNT_"*"_(STDCNT+ODICNT)_"*"_TOSTDCNT_"*"_TOODICNT_"*"_TOALLCNT
- +18 ; reset to 0, begin counting Line items for INVPT
- SET IN4=0
- +19 SET TOTDOL=0
- +20 SET LNDOL=0
- +21 SET PRCPDX=""
- +22 SET CSTCTR=""
- +23 SET (STDDOL,ODIDOL)=0
- End DoDot:3
- +24 FOR
- SET IN3=$ORDER(^TMP($JOB,"PRCPLO",IN1,IN2,IN3))
- if IN3=""
- QUIT
- Begin DoDot:3
- +25 SET INDDAT=$GET(^TMP($JOB,"PRCPLO",IN1,IN2,IN3))
- +26 SET STID=$PIECE(INDDAT,"*",1)
- +27 SET DTTM=$PIECE(INDDAT,"*",2)
- +28 SET POINT=$PIECE(INDDAT,"*",4)
- +29 ; Inv Point ID# for DIE Set
- SET INPTVAL=$PIECE(INDDAT,"*",3)
- +30 SET CSTCTR=$PIECE(INDDAT,"*",7)
- +31 SET LNDOL=$PIECE(INDDAT,"*",6)
- +32 SET INVVTYP=$PIECE(INDDAT,"*",8)
- +33 SET TOTDOL=TOTDOL+LNDOL
- +34 ; Count # of line items in Inv Pt
- SET IN4=IN4+1
- +35 ; Invt. Point
- SET IN5=IN2
- +36 SET STDDOL=STDDOL+$GET(^TMP($JOB,"PRCPLO2",IN1,IN2,IN3,1))
- +37 SET ODIDOL=ODIDOL+$GET(^TMP($JOB,"PRCPLO2",IN1,IN2,IN3,2))
- +38 QUIT
- End DoDot:3
- +39 QUIT
- End DoDot:2
- +40 QUIT
- End DoDot:1
- +41 QUIT
- GETVAL ; Get values from ^TMP($J,"PRCPSOH"
- +1 NEW LP1,SOHIEN,PRCPDX
- +2 SET LP1=0
- +3 FOR
- SET LP1=$ORDER(^TMP($JOB,"PRCPSOH",LP1))
- if LP1=""
- QUIT
- Begin DoDot:1
- +4 SET PRCPDX=$GET(^TMP($JOB,"PRCPSOH",LP1))
- +5 SET SOHIEN=+LP1
- +6 SET DR="1///"_PRCPDX
- +7 DO SETREC
- +8 SET PRCPDX=$GET(^TMP($JOB,"PRCPSOH2",LP1))
- +9 SET DR="2///"_PRCPDX
- +10 DO SETREC
- +11 QUIT
- End DoDot:1
- +12 QUIT
- SETREC ; Set record using DIE in 446.7
- +1 ;
- +2 NEW PRCPDR,PRCPST,PRCPSNM,PRCPDA,PRCPDX,PRCPST,X,Y
- +3 SET PRCPDR=DR
- +4 SET DIC="^PRCP(446.7,"
- SET DIC(0)="L"
- SET DLAYGO=446.7
- SET X=SOHIEN
- DO ^DIC
- KILL DIC,DLAYGO
- +5 SET PRCPDA=Y+0
- +6 SET PRCPST=$PIECE(^TMP($JOB,"PRCPSOH",LP1),"*",1)
- +7 SET PRCPSNM=$$GET1^DIQ(4,PRCPST_",",.01)
- +8 ;*98 Send enhanced mail message if exception occurs during FileMan set
- +9 IF Y=-1
- NEW PRCPMSG
- Begin DoDot:1
- +10 SET PRCPMSG(1)="Error saving to File #446.7 for Days of Stock on Hand Report, related data: "
- +11 SET PRCPMSG(2)=""
- SET PRCPMSG(3)="Station: "_PRCPST_" "_PRCPSNM
- +12 SET PRCPMSG(4)="Inventory Point: "_$PIECE(^TMP($JOB,"PRCPSOH",LP1),"*",3)_" "_$PIECE(^TMP($JOB,"PRCPSOH",LP1),"*",4)
- +13 SET PRCPMSG(5)="File #446.7 Field Set Attempted: "_PRCPDR
- +14 DO MAIL^PRCPLO3
- QUIT
- End DoDot:1
- QUIT
- +15 ;
- +16 SET DIE="^PRCP(446.7,"
- SET DA=PRCPDA
- DO ^DIE
- KILL DIE,DR,DA
- +17 QUIT
