PRCHITX1 ;WOIFO/LKG-WRITING ITEM DATA FOR NIF TO DAT FILES ;12/27/04 17:58
;;5.1;IFCAP;**75**;OCT 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
START ;Writes .dat file of vendor and item information to host file
D EN^DDIOL("This option writes item information to the .dat file.")
D EN^DDIOL("It is recommended to queue this extract for a time of low user activity.",,"!!")
N %ZIS,ZTRTN,ZTDESC,PRCPHYS
K Y,DIR S DIR(0)="Y",DIR("A")="Include physical inventory count transactions in the analysis",DIR("B")="NO"
S DIR("?",1)="Answer 'YES' if you have a large number of items that have recently been"
S DIR("?",2)="added to your GIP inventory, but have not yet been received or issued."
S DIR("?")="Answer 'NO' to exclude slow moving stock from NIF processing."
D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) G ITX
S PRCPHYS=$S(Y=1:"Y",1:"N") K Y
S %ZIS="Q",%ZIS("A")="Host File Device: ",%ZIS("B")="PRC_WIDE_HOST_FILE"
D ^%ZIS G:POP ITX
I $D(IO("Q")) D Q
. S ZTRTN="COMPILE^PRCHITX1",ZTDESC="Item Extraction for NIF",ZTSAVE("PRCPHYS")=""
. D ^%ZTLOAD,HOME^%ZIS
. D EN^DDIOL("Task #"_ZTSK) K IO("Q"),ZTSK
COMPILE ;invoke the item and vendor compile
N X,Y,PRCSTA,PRCV,PRCW,PRCX,PRCY,PRCZ
D IN^PRCHITX
S PRCSTA=$$GETSTATN^PRCHITX
U IO
VENDOR ;Write vendor data
S PRCX=""
F S PRCX=$O(^TMP($J,"V",PRCX)) Q:PRCX="" D
. S PRCY=$G(^TMP($J,"V",PRCX)) Q:PRCY=""
. S PRCZ="6^9^"_PRCSTA_"^"_PRCX_"^"_$P(PRCY,"^")_"^"_$P(PRCY,"^",4)_"^"_$P(PRCY,"^",3)_"^"_$P(PRCY,"^",2)_"^"_$P(PRCY,"^",5)
. W PRCZ,!
ITEM ;Write item data
S PRCX=""
F S PRCX=$O(^TMP($J,"I",PRCX)) Q:PRCX="" D
. S PRCY=$G(^TMP($J,"I",PRCX,0)) Q:PRCY=""
. S PRCZ="6^0^"_PRCSTA_"^"_$P(PRCY,"^",8)_"^"_PRCX_"^"_$$GETSDESC^PRCHITX(PRCX)_"^"
. W PRCZ
. S X=0,Y=1
. F S X=$O(^PRC(441,PRCX,1,X)) Q:X="" D
. . S PRCZ=$G(^PRC(441,PRCX,1,X,0)),PRCZ=$TR(PRCZ,"^") Q:PRCZ=""
. . W:Y>1 " " W PRCZ S Y=Y+1
. S PRCZ="^^"_$P(PRCY,"^",6)_"^"_$P(PRCY,"^",4)_"^" W PRCZ
. S PRCW=$G(^TMP($J,"I",PRCX,1)),PRCV=$P(PRCW,"^")
. S PRCZ=$P(PRCY,"^",5)_"^^"_PRCV_"^^^^"_$P(PRCW,"^",4)_"^0^"_$P(PRCW,"^",2)_"^"_$P(PRCW,"^",3)_"^"
. W PRCZ
. S PRCZ=$P(PRCY,"^",3)_"^"_$P(PRCW,"^",6)_"^^"_$P(PRCW,"^",5)
. W PRCZ,!
D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@"
D:'$D(ZTQUEUED) EN^DDIOL("<DONE>")
K PRCW,PRCX,PRCY,PRCZ S PRCW=$$KSP^XUPARAM("WHERE")
K XMZ,XMMG,XMDUZ,XMY,XMSUB,XMTEXT
S PRCX(1)="Record counts for NIF Item Extract File from Station "_PRCSTA
S PRCX(2)=" "
S PRCX(3)=" Number of items: "_$G(^TMP($J,"I"),0)
S PRCX(4)=" Number of vendors: "_$G(^TMP($J,"V"),0)
S PRCX(5)=" ",PRCX(6)="Physical count transactions were "_$S(PRCPHYS="Y":"",1:"not ")_"included in the analysis."
X ^%ZOSF("UCI") S PRCY=^%ZOSF("PROD") S:PRCY'["," Y=$P(Y,",")
I Y=PRCY,PRCW'["FO-",PRCW'["ISC-" S XMY("prchitem@domain.ext")=""
I $G(DUZ)>0,$D(^VA(200,DUZ)) D
. N PRCNAME
. S XMY(DUZ)=""
. S PRCNAME("FILE")=200,PRCNAME("IENS")=DUZ_",",PRCNAME("FIELD")=.01
. S PRCX(7)=" ",PRCX(8)="The extraction process was run by "_$$NAMEFMT^XLFNAME(.PRCNAME,"G","M")_"."
S XMSUB="NIF Item Extract Statistics for Station "_PRCSTA
S XMDUZ="NIF ITEM EXTRACTOR"
S XMTEXT="PRCX(" D ^XMD
I $G(XMZ),'$D(ZTQUEUED) D EN^DDIOL("MailMan message #"_$G(XMZ)_" with extract statistics was sent.")
K XMZ,XMMG,XMDUZ,XMY,XMSUB,XMTEXT,PRCPHYS
ITX ;EXIT
K POP,^TMP($J),DTOUT,DUOUT,DIRUT,DIROUT,Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHITX1 3445 printed Sep 23, 2025@19:44:11 Page 2
PRCHITX1 ;WOIFO/LKG-WRITING ITEM DATA FOR NIF TO DAT FILES ;12/27/04 17:58
+1 ;;5.1;IFCAP;**75**;OCT 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
START ;Writes .dat file of vendor and item information to host file
+1 DO EN^DDIOL("This option writes item information to the .dat file.")
+2 DO EN^DDIOL("It is recommended to queue this extract for a time of low user activity.",,"!!")
+3 NEW %ZIS,ZTRTN,ZTDESC,PRCPHYS
+4 KILL Y,DIR
SET DIR(0)="Y"
SET DIR("A")="Include physical inventory count transactions in the analysis"
SET DIR("B")="NO"
+5 SET DIR("?",1)="Answer 'YES' if you have a large number of items that have recently been"
+6 SET DIR("?",2)="added to your GIP inventory, but have not yet been received or issued."
+7 SET DIR("?")="Answer 'NO' to exclude slow moving stock from NIF processing."
+8 DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
GOTO ITX
+9 SET PRCPHYS=$SELECT(Y=1:"Y",1:"N")
KILL Y
+10 SET %ZIS="Q"
SET %ZIS("A")="Host File Device: "
SET %ZIS("B")="PRC_WIDE_HOST_FILE"
+11 DO ^%ZIS
if POP
GOTO ITX
+12 IF $DATA(IO("Q"))
Begin DoDot:1
+13 SET ZTRTN="COMPILE^PRCHITX1"
SET ZTDESC="Item Extraction for NIF"
SET ZTSAVE("PRCPHYS")=""
+14 DO ^%ZTLOAD
DO HOME^%ZIS
+15 DO EN^DDIOL("Task #"_ZTSK)
KILL IO("Q"),ZTSK
End DoDot:1
QUIT
COMPILE ;invoke the item and vendor compile
+1 NEW X,Y,PRCSTA,PRCV,PRCW,PRCX,PRCY,PRCZ
+2 DO IN^PRCHITX
+3 SET PRCSTA=$$GETSTATN^PRCHITX
+4 USE IO
VENDOR ;Write vendor data
+1 SET PRCX=""
+2 FOR
SET PRCX=$ORDER(^TMP($JOB,"V",PRCX))
if PRCX=""
QUIT
Begin DoDot:1
+3 SET PRCY=$GET(^TMP($JOB,"V",PRCX))
if PRCY=""
QUIT
+4 SET PRCZ="6^9^"_PRCSTA_"^"_PRCX_"^"_$PIECE(PRCY,"^")_"^"_$PIECE(PRCY,"^",4)_"^"_$PIECE(PRCY,"^",3)_"^"_$PIECE(PRCY,"^",2)_"^"_$PIECE(PRCY,"^",5)
+5 WRITE PRCZ,!
End DoDot:1
ITEM ;Write item data
+1 SET PRCX=""
+2 FOR
SET PRCX=$ORDER(^TMP($JOB,"I",PRCX))
if PRCX=""
QUIT
Begin DoDot:1
+3 SET PRCY=$GET(^TMP($JOB,"I",PRCX,0))
if PRCY=""
QUIT
+4 SET PRCZ="6^0^"_PRCSTA_"^"_$PIECE(PRCY,"^",8)_"^"_PRCX_"^"_$$GETSDESC^PRCHITX(PRCX)_"^"
+5 WRITE PRCZ
+6 SET X=0
SET Y=1
+7 FOR
SET X=$ORDER(^PRC(441,PRCX,1,X))
if X=""
QUIT
Begin DoDot:2
+8 SET PRCZ=$GET(^PRC(441,PRCX,1,X,0))
SET PRCZ=$TRANSLATE(PRCZ,"^")
if PRCZ=""
QUIT
+9 if Y>1
WRITE " "
WRITE PRCZ
SET Y=Y+1
End DoDot:2
+10 SET PRCZ="^^"_$PIECE(PRCY,"^",6)_"^"_$PIECE(PRCY,"^",4)_"^"
WRITE PRCZ
+11 SET PRCW=$GET(^TMP($JOB,"I",PRCX,1))
SET PRCV=$PIECE(PRCW,"^")
+12 SET PRCZ=$PIECE(PRCY,"^",5)_"^^"_PRCV_"^^^^"_$PIECE(PRCW,"^",4)_"^0^"_$PIECE(PRCW,"^",2)_"^"_$PIECE(PRCW,"^",3)_"^"
+13 WRITE PRCZ
+14 SET PRCZ=$PIECE(PRCY,"^",3)_"^"_$PIECE(PRCW,"^",6)_"^^"_$PIECE(PRCW,"^",5)
+15 WRITE PRCZ,!
End DoDot:1
+16 DO ^%ZISC
+17 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+18 if '$DATA(ZTQUEUED)
DO EN^DDIOL("<DONE>")
+19 KILL PRCW,PRCX,PRCY,PRCZ
SET PRCW=$$KSP^XUPARAM("WHERE")
+20 KILL XMZ,XMMG,XMDUZ,XMY,XMSUB,XMTEXT
+21 SET PRCX(1)="Record counts for NIF Item Extract File from Station "_PRCSTA
+22 SET PRCX(2)=" "
+23 SET PRCX(3)=" Number of items: "_$GET(^TMP($JOB,"I"),0)
+24 SET PRCX(4)=" Number of vendors: "_$GET(^TMP($JOB,"V"),0)
+25 SET PRCX(5)=" "
SET PRCX(6)="Physical count transactions were "_$SELECT(PRCPHYS="Y":"",1:"not ")_"included in the analysis."
+26 XECUTE ^%ZOSF("UCI")
SET PRCY=^%ZOSF("PROD")
if PRCY'[","
SET Y=$PIECE(Y,",")
+27 IF Y=PRCY
IF PRCW'["FO-"
IF PRCW'["ISC-"
SET XMY("prchitem@domain.ext")=""
+28 IF $GET(DUZ)>0
IF $DATA(^VA(200,DUZ))
Begin DoDot:1
+29 NEW PRCNAME
+30 SET XMY(DUZ)=""
+31 SET PRCNAME("FILE")=200
SET PRCNAME("IENS")=DUZ_","
SET PRCNAME("FIELD")=.01
+32 SET PRCX(7)=" "
SET PRCX(8)="The extraction process was run by "_$$NAMEFMT^XLFNAME(.PRCNAME,"G","M")_"."
End DoDot:1
+33 SET XMSUB="NIF Item Extract Statistics for Station "_PRCSTA
+34 SET XMDUZ="NIF ITEM EXTRACTOR"
+35 SET XMTEXT="PRCX("
DO ^XMD
+36 IF $GET(XMZ)
IF '$DATA(ZTQUEUED)
DO EN^DDIOL("MailMan message #"_$GET(XMZ)_" with extract statistics was sent.")
+37 KILL XMZ,XMMG,XMDUZ,XMY,XMSUB,XMTEXT,PRCPHYS
ITX ;EXIT
+1 KILL POP,^TMP($JOB),DTOUT,DUOUT,DIRUT,DIROUT,Y
+2 QUIT
