PRCH442A ;WISC/KMB/CR/DXH/DGL-CREATE PURCHASE CARD ORDER FROM RIL ;4/13/00 1:32pm
;;5.1;IFCAP;**8,35,26,57,81,106**;Oct 20, 2000
;Per VHA Directive 2004-038, this routine should not be modified.
;
SETUP ; create 442 entry
D ENPO^PRCHUTL
;
; PRC*5.1*81 - If this is a DynaMed RIL, double dare users who try to exit before all items on the RIL are transferred to purchase card orders
I '$D(DA),'PRCVDYN S OUTRIL=1 W !,"Unable to create 442 entry. Try later." Q
I '$D(DA) D G SETUP:Y=0 S OUTRIL=1 Q
. N DIR
. S DIR(0)="Y",DIR("B")="NO"
. S DIR("A",1)=" "
. S DIR("A",2)="NOTE: This RIL Contains DynaMed Orders!!!"
. S DIR("A",3)="-----------------------------------------"
. S DIR("A",4)="You must enter a valid PURCHASE ORDER NUMBER to continue. If no valid"
. S DIR("A",5)="PURCHASE ORDER is entered, all items remaining on the RIL will be deleted."
. S DIR("A",6)=" "
. S DIR("A")="Do you want to exit and delete the RIL?"
. S DIR("?")="Enter 'NO' or <return> to go back to the PURCHASE ORDER prompt"
. D ^DIR Q:Y=0
. S DIR("A")="Are you sure that you want to cancel ALL DynaMed Orders on this RIL?"
. D ^DIR
;
I '$G(^PRCS(410.3,XDA,0)) D S OUTRIL=1 W !!,"Another user has deleted this RIL, Purchase Order will now be deleted.",!! Q
. S DIK="^PRC(442,",DA=DA
. D ^DIK
N PRCHCPD,CP1
S PDA=DA L +^PRC(442,PDA):15 Q:'$T
S DIE="^PRC(442,",DR=".5////1"_";"_"1.4////"_APP D ^DIE ;LIT-0400-70331
I $G(RLFLAG)'=1 S DR=".02///25"_";"_"48///P" D ^DIE
I $G(RLFLAG)=1 S DR=".02///1"_";"_"47///Y"_";"_"48///D" D ^DIE
S $P(^PRC(442,PDA,1),"^")=VENDOR,$P(^(0),"^",3)=FCP,$P(^(0),"^",5)=CCEN,$P(^(23),"^",7)=PRC("SST"),$P(^(23),"^",14)=VENDOR
S DIE="^PRC(442,",DR=".03///"_SPEC_";"_".1////"_TDATE D ^DIE
;
; PRC*5.1*81
I PRCVDYN S DR="7///"_PRCVDATE_";"_"54///Y" D ^DIE ; save earliest Need By Date in RIL for vendor in PC order delivery date, force 'Requested Receipt?' to Yes
;
;BUT-0701-21784 & WAS-0498-22000
S CP1=$P($P(^PRCS(410.3,XDA,0),U),"-",4)
S ^PRC(442,"E",CP1,PDA)=""
;
S $P(^PRC(442,PDA,1),"^",10)=DUZ,^PRC(442,"D",$E(VENDOR,1,30),PDA)=""
I NCOST'=0 F II=1:1:CNNT D SETIT
I NCOST'=0 S ^PRC(442,PDA,2,0)="^442.01IA^"_CNNT_"^"_CNNT
S EE($J,PDA)=""
;
N NCST,NLP,NCNT,NQTY,NSUB
LOOP S %=1 W !,"Edit request ",$P(^PRC(442,PDA,0),"^")
D YN^DICN G:%=0 LOOP G:%=2 LQ
S (PRCHPO,DA)=PDA,PRC("PER")=DUZ,X=1
D ^PRCHNPO,LOOPA
K PRC("PER"),X,PRCHPO
LQ L -^PRC(442,PDA) Q
;
LOOPA Q:$G(^PRC(442,PDA,2,0))="" S NCNT=$P($G(^PRC(442,PDA,2,0)),U,4) Q:NCNT="" S NSUB=0 F NLP=1:1:NCNT D
.S NQTY=$P($G(^PRC(442,PDA,2,NLP,0)),U,2),NCST=$P($G(^PRC(442,PDA,2,NLP,0)),U,9),NSUB=NSUB+(NQTY*NCST)
S CNNT=NCNT,NCOST=NSUB Q
;
SETIT ;set item data on 442 record
S ^PRC(442,PDA,2,II,0)=AA(II)
I CNNT1'="" F J=1:1:CNNT1 S ^PRC(442,PDA,2,II,1,J,0)=$G(BB(II,J))
S ^PRC(442,PDA,2,II,2)=CC(II)
;
; PRC*5.1*81
I PRCVDYN D
. N PRCV S PRCV=0
. I $P(CC(II),"^",15)]"" S PRCV=$O(^PRCV(414.02,"B",$P(CC(II),"^",15),"")) ; get ien of DM DOC ID
. I +PRCV=0 D Q ; if not in audit file update ^TMP to alert user
. . S ^TMP($J,"PRCVHMSG",YDA,ITEM)=$P(CC(II),"^",15)_"^"_$P(^PRC(442,PDA,0),"^",1) Q ; update msg to user to show DM, DOC ID & PO#
. S $P(^PRCV(414.02,PRCV,0),"^",11)=$P(^PRC(442,PDA,0),"^",1) ; SET PO Number into Audit file
;
S ^PRC(442,PDA,2,II,1,0)="^^"_CNNT1_"^"_CNNT1_"^"_TDATE_"^"
S ^PRC(442,PDA,2,"B",II,II)="",^PRC(442,PDA,2,"C",II,II)=""
S ^PRC(442,PDA,2,"AE",ITEM,II)="" S:BOC'="" ^PRC(442,PDA,2,"AH",+BOC,II,II)="",^PRC(442,PDA,2,"D",+BOC,II)=""
I $G(PRCSIP) D
. N DIC,DIE,DA,DLAYGO
. S DIC="^PRC(442,"_PDA_",2,"_II_",5,",DA(1)=II,DA(2)=PDA,X=PRCSIP
. S DIC(0)="L",DIC("P")=$P(^DD(442.01,47,0),U,2),DLAYGO=442
. D FILE^DICN
K DIE
;
; PRC*5.1*81 - delete items from RIL as they are moved to a PC order
I PRCVDYN D
. N DA,DIK
. S DA=GG(II),DA(1)=YDA,DIK="^PRCS(410.3,"_DA(1)_",1,"
. D ^DIK
;
S PRCHCPD=TDATE,PRCHCV=VENDOR,(DA(1),PRCHCPO)=PDA,PRCHCCP=CP1,(PRCHCI,PRCHCII,X)=$P(AA(II),"^",5),DA=II
I PRCHCI'="" D EN3^PRCHCRD S ^PRC(442,PDA,2,"AE",PRCHCII,II)=""
K PRCHCCP,PRCHCPO,PRCHCV,PRCHCI,PRCHCII
QUIT
;
INCOM1 S FLAG=0
INCOM2 S:$G(FLAG)="" FLAG=1
INCOM ;
K ^TMP($J)
N ZP,LABEL,PC1,PONUM,PODATE,STAT,PANAME,ADATE,Y,XXZ,EX,P,P1,P12,P2,P23,STR,TIMEDATE
S:$G(FLAG)="" LABEL="INCOM" S:$G(FLAG)=0 LABEL="INCOM1" S:$G(FLAG)=1 LABEL="INCOM2"
W @IOF
S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) Q:$G(PRC("SITE"))="^"
W !,"Please select a device for printing this report."
S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) S ZTSAVE("*")="",ZTRTN="DETAIL^PRCH442A" D ^%ZTLOAD,^%ZISC K FLAG Q
D DETAIL,^%ZISC K FLAG
Q
;
DETAIL ;
S X=DT D NOW^%DTC,YX^%DTC S TIMEDATE=Y,CNT=0
S ZP="" F S ZP=$O(^PRC(442,"F",25,ZP)) Q:ZP="" D
.Q:$P($G(^PRC(442,ZP,7)),"^")=45
.Q:$D(^PRC(442,ZP,11))
.Q:$P($G(^PRC(442,ZP,12)),"^",2)'=""
.S P1=$G(^PRC(442,ZP,0)),PONUM=$P(P1,"^")
.I $D(PRC("SITE")) Q:$P(P1,"-")'=PRC("SITE")
.S PC1=$P($G(^PRC(442,ZP,23)),"^",8) I PC1="" D DETAIL1
.Q:PC1=""
.I $G(FLAG)=0 Q:$P($G(^PRC(440.5,PC1,0)),"^",8)'=DUZ
.I $G(FLAG)=1 I $P($G(^PRC(440.5,PC1,0)),"^",10)'=DUZ,$P($G(^PRC(440.5,PC1,0)),"^",9)'=DUZ Q
.S P2=$G(^PRC(442,ZP,1)),PA=$P($G(^PRC(440.5,PC1,0)),"^",8) Q:PA=""
.S PANAME=$P($G(^VA(200,PA,0)),"^") Q:PANAME=""
.S Y=$P(P2,"^",15) D DD^%DT S PODATE=Y
.S STAT=$P($G(^PRC(442,ZP,7)),"^") S:STAT'="" STAT=$P($G(^PRCD(442.3,STAT,0)),"^")
.S Y=$P($G(^PRC(442,ZP,12)),"^",5) D DD^%DT S ADATE=Y
.S ^TMP($J,ZP)=PONUM_"^"_PODATE_"^"_STAT_"^"_PANAME_"^"_ADATE,CNT=$G(CNT)+1
D WRTE
W:$D(^TMP($J)) !!!,?10,"Total number of orders found: "_CNT
K ^TMP($J),CNT
Q
;
DETAIL1 ;Get tally for the PC user and exclude the Approving Official.
Q:$G(FLAG)=1
;if the PC Coordinator is asking for the report, get the orders.
I $G(FLAG)="" D DETAIL2
Q:$P($G(^PRC(442,ZP,12)),"^",4)'=DUZ!($G(FLAG)'=0)
S PA=$P(^PRC(442,ZP,12),"^",4),PANAME=$P(^VA(200,PA,0),"^") Q:PANAME=""
S Y=$P(^PRC(442,ZP,12),"^",5) D DD^%DT S ADATE=Y,PODATE=$P(Y,"@",1)
S STAT=$P($G(^PRC(442,ZP,7)),"^") S:STAT'="" STAT=$P($G(^PRCD(442.3,STAT,0)),"^")
S ^TMP($J,ZP)=PONUM_"^"_PODATE_"^"_STAT_"^"_PANAME_"^"_ADATE,CNT=$G(CNT)+1
Q
;
DETAIL2 ;Get tally for the PC Coordinator.
S PA=$P(^PRC(442,ZP,12),"^",4),PANAME=$P(^VA(200,PA,0),"^") Q:PANAME=""
S Y=$P(^PRC(442,ZP,12),"^",5) D DD^%DT S ADATE=Y,PODATE=$P(Y,"@",1)
S STAT=$P($G(^PRC(442,ZP,7)),"^") S:STAT'="" STAT=$P($G(^PRCD(442.3,STAT,0)),"^")
S ^TMP($J,ZP)=PONUM_"^"_PODATE_"^"_STAT_"^"_PANAME_"^"_ADATE,CNT=$G(CNT)+1
Q
;
WRTE ;
U IO S (P,EX)=1
I '$D(^TMP($J)) D HDR W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q
S ZP="" F S ZP=$O(^TMP($J,ZP)) Q:ZP="" Q:EX="^" D
.D:P=1 HDR
.W !,$P(^TMP($J,ZP),"^"),?21,$P(^TMP($J,ZP),"^",2),?40,$P(^TMP($J,ZP),"^",3),!,?10,$P(^TMP($J,ZP),"^",4),?40,$P(^TMP($J,ZP),"^",5),!
.I (IOSL-$Y)<6 D HLD Q:EX="^"
QUIT
;
C2237 ;cancel 2237 from PC order
N I,N,T,X,ZX,PRCVIEN
Q:'$D(DA) S YDA=DA,PRCVIEN=DA,XDA=$P($G(^PRC(442,DA,23)),"^",23) Q:XDA="" L +^PRCS(410,XDA):15 Q:'$T
S PRC("CP")=$P($G(^PRC(442,YDA,0)),"^",3) Q:+PRC("CP")=""
S T=$P(^PRCS(410,XDA,0),"^"),$P(^(11),"^",3)="",$P(^(0),"^",2)="CA",$P(^(5),"^")=0,$P(^(6),"^")=0 K ^PRCS(410,"F",+T_"-"_+PRC("CP")_"-"_$P(T,"-",5),XDA),^PRCS(410,"F1",$P(T,"-",5)_"-"_+T_"-"_+PRC("CP"),XDA),^PRCS(410,"AQ",1,XDA)
K ZX I $D(^PRCS(410,XDA,4)) S ZX=^(4),X=$P(ZX,"^",8) F I=1,3,6,8 S $P(ZX,"^",I)=0
I $D(ZX) S ^PRCS(410,XDA,4)=ZX K ZX
I $D(^PRCS(410,XDA,12,0)) S N=0 F I=0:0 S N=$O(^PRCS(410,XDA,12,N)) Q:N'>0 S X=$P(^(N,0),"^",2) I X S DA(1)=XDA,DA=N D TRANK^PRCSEZZ S XDA=DA(1)
D ERS410^PRC0G(XDA_"^C")
L -^PRCS(410,XDA)
I $D(^PRC(443,XDA,0)) S DA=XDA,DIK="^PRC(443," D ^DIK K DIK
S DA=YDA
; PRC*5.1*81 - if site runs DynaMed, may need to build update txn
I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 D DEL^PRCV442A(PRCVIEN)
QUIT
;
RENUM ; delete delivery order items from repetitive item list
Q:$G(^PRCS(410.3,YDA,0))=""
L +^PRCS(410.3,YDA):15 Q:'$T
S IJ="" F S IJ=$O(^PRCS(410.3,YDA,1,IJ)) Q:IJ="" D
.I $P($G(^PRCS(410.3,YDA,1,IJ,0)),"^",6)="O" S DA=IJ,DA(1)=YDA,DIK="^PRCS(410.3,"_DA(1)_",1," D ^DIK
L -^PRCS(410.3,YDA)
I $P($G(^PRCS(410.3,YDA,1,0)),"^",4)=0 W !,"This Repetitive Item List has no more items, and will be deleted." S DA=YDA,DIK="^PRCS(410.3," D ^DIK
K DIK QUIT
;
HDR W @IOF
W !,"INCOMPLETE PURCHASE CARD ORDERS REPORT",?45,TIMEDATE,?70,"PAGE ",P
W !,"PURCHASE CARD ORDER",?21,"PO DATE",?40,"SUPPLY STATUS",!,?10,"BUYER",?40,"DATE PO ASSIGNED"
W ! F I=1:1:8 W "----------"
S P=P+1
QUIT
;
HLD G HDR:$P(IOST,"-")="P" W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ="^" EX="^" S:'$T EX="^" D:EX'["^" HDR QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCH442A 8781 printed Dec 13, 2024@02:05:14 Page 2
PRCH442A ;WISC/KMB/CR/DXH/DGL-CREATE PURCHASE CARD ORDER FROM RIL ;4/13/00 1:32pm
+1 ;;5.1;IFCAP;**8,35,26,57,81,106**;Oct 20, 2000
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
SETUP ; create 442 entry
+1 DO ENPO^PRCHUTL
+2 ;
+3 ; PRC*5.1*81 - If this is a DynaMed RIL, double dare users who try to exit before all items on the RIL are transferred to purchase card orders
+4 IF '$DATA(DA)
IF 'PRCVDYN
SET OUTRIL=1
WRITE !,"Unable to create 442 entry. Try later."
QUIT
+5 IF '$DATA(DA)
Begin DoDot:1
+6 NEW DIR
+7 SET DIR(0)="Y"
SET DIR("B")="NO"
+8 SET DIR("A",1)=" "
+9 SET DIR("A",2)="NOTE: This RIL Contains DynaMed Orders!!!"
+10 SET DIR("A",3)="-----------------------------------------"
+11 SET DIR("A",4)="You must enter a valid PURCHASE ORDER NUMBER to continue. If no valid"
+12 SET DIR("A",5)="PURCHASE ORDER is entered, all items remaining on the RIL will be deleted."
+13 SET DIR("A",6)=" "
+14 SET DIR("A")="Do you want to exit and delete the RIL?"
+15 SET DIR("?")="Enter 'NO' or <return> to go back to the PURCHASE ORDER prompt"
+16 DO ^DIR
if Y=0
QUIT
+17 SET DIR("A")="Are you sure that you want to cancel ALL DynaMed Orders on this RIL?"
+18 DO ^DIR
End DoDot:1
if Y=0
GOTO SETUP
SET OUTRIL=1
QUIT
+19 ;
+20 IF '$GET(^PRCS(410.3,XDA,0))
Begin DoDot:1
+21 SET DIK="^PRC(442,"
SET DA=DA
+22 DO ^DIK
End DoDot:1
SET OUTRIL=1
WRITE !!,"Another user has deleted this RIL, Purchase Order will now be deleted.",!!
QUIT
+23 NEW PRCHCPD,CP1
+24 SET PDA=DA
LOCK +^PRC(442,PDA):15
if '$TEST
QUIT
+25 ;LIT-0400-70331
SET DIE="^PRC(442,"
SET DR=".5////1"_";"_"1.4////"_APP
DO ^DIE
+26 IF $GET(RLFLAG)'=1
SET DR=".02///25"_";"_"48///P"
DO ^DIE
+27 IF $GET(RLFLAG)=1
SET DR=".02///1"_";"_"47///Y"_";"_"48///D"
DO ^DIE
+28 SET $PIECE(^PRC(442,PDA,1),"^")=VENDOR
SET $PIECE(^(0),"^",3)=FCP
SET $PIECE(^(0),"^",5)=CCEN
SET $PIECE(^(23),"^",7)=PRC("SST")
SET $PIECE(^(23),"^",14)=VENDOR
+29 SET DIE="^PRC(442,"
SET DR=".03///"_SPEC_";"_".1////"_TDATE
DO ^DIE
+30 ;
+31 ; PRC*5.1*81
+32 ; save earliest Need By Date in RIL for vendor in PC order delivery date, force 'Requested Receipt?' to Yes
IF PRCVDYN
SET DR="7///"_PRCVDATE_";"_"54///Y"
DO ^DIE
+33 ;
+34 ;BUT-0701-21784 & WAS-0498-22000
+35 SET CP1=$PIECE($PIECE(^PRCS(410.3,XDA,0),U),"-",4)
+36 SET ^PRC(442,"E",CP1,PDA)=""
+37 ;
+38 SET $PIECE(^PRC(442,PDA,1),"^",10)=DUZ
SET ^PRC(442,"D",$EXTRACT(VENDOR,1,30),PDA)=""
+39 IF NCOST'=0
FOR II=1:1:CNNT
DO SETIT
+40 IF NCOST'=0
SET ^PRC(442,PDA,2,0)="^442.01IA^"_CNNT_"^"_CNNT
+41 SET EE($JOB,PDA)=""
+42 ;
+43 NEW NCST,NLP,NCNT,NQTY,NSUB
LOOP SET %=1
WRITE !,"Edit request ",$PIECE(^PRC(442,PDA,0),"^")
+1 DO YN^DICN
if %=0
GOTO LOOP
if %=2
GOTO LQ
+2 SET (PRCHPO,DA)=PDA
SET PRC("PER")=DUZ
SET X=1
+3 DO ^PRCHNPO
DO LOOPA
+4 KILL PRC("PER"),X,PRCHPO
LQ LOCK -^PRC(442,PDA)
QUIT
+1 ;
LOOPA if $GET(^PRC(442,PDA,2,0))=""
QUIT
SET NCNT=$PIECE($GET(^PRC(442,PDA,2,0)),U,4)
if NCNT=""
QUIT
SET NSUB=0
FOR NLP=1:1:NCNT
Begin DoDot:1
+1 SET NQTY=$PIECE($GET(^PRC(442,PDA,2,NLP,0)),U,2)
SET NCST=$PIECE($GET(^PRC(442,PDA,2,NLP,0)),U,9)
SET NSUB=NSUB+(NQTY*NCST)
End DoDot:1
+2 SET CNNT=NCNT
SET NCOST=NSUB
QUIT
+3 ;
SETIT ;set item data on 442 record
+1 SET ^PRC(442,PDA,2,II,0)=AA(II)
+2 IF CNNT1'=""
FOR J=1:1:CNNT1
SET ^PRC(442,PDA,2,II,1,J,0)=$GET(BB(II,J))
+3 SET ^PRC(442,PDA,2,II,2)=CC(II)
+4 ;
+5 ; PRC*5.1*81
+6 IF PRCVDYN
Begin DoDot:1
+7 NEW PRCV
SET PRCV=0
+8 ; get ien of DM DOC ID
IF $PIECE(CC(II),"^",15)]""
SET PRCV=$ORDER(^PRCV(414.02,"B",$PIECE(CC(II),"^",15),""))
+9 ; if not in audit file update ^TMP to alert user
IF +PRCV=0
Begin DoDot:2
+10 ; update msg to user to show DM, DOC ID & PO#
SET ^TMP($JOB,"PRCVHMSG",YDA,ITEM)=$PIECE(CC(II),"^",15)_"^"_$PIECE(^PRC(442,PDA,0),"^",1)
QUIT
End DoDot:2
QUIT
+11 ; SET PO Number into Audit file
SET $PIECE(^PRCV(414.02,PRCV,0),"^",11)=$PIECE(^PRC(442,PDA,0),"^",1)
End DoDot:1
+12 ;
+13 SET ^PRC(442,PDA,2,II,1,0)="^^"_CNNT1_"^"_CNNT1_"^"_TDATE_"^"
+14 SET ^PRC(442,PDA,2,"B",II,II)=""
SET ^PRC(442,PDA,2,"C",II,II)=""
+15 SET ^PRC(442,PDA,2,"AE",ITEM,II)=""
if BOC'=""
SET ^PRC(442,PDA,2,"AH",+BOC,II,II)=""
SET ^PRC(442,PDA,2,"D",+BOC,II)=""
+16 IF $GET(PRCSIP)
Begin DoDot:1
+17 NEW DIC,DIE,DA,DLAYGO
+18 SET DIC="^PRC(442,"_PDA_",2,"_II_",5,"
SET DA(1)=II
SET DA(2)=PDA
SET X=PRCSIP
+19 SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(442.01,47,0),U,2)
SET DLAYGO=442
+20 DO FILE^DICN
End DoDot:1
+21 KILL DIE
+22 ;
+23 ; PRC*5.1*81 - delete items from RIL as they are moved to a PC order
+24 IF PRCVDYN
Begin DoDot:1
+25 NEW DA,DIK
+26 SET DA=GG(II)
SET DA(1)=YDA
SET DIK="^PRCS(410.3,"_DA(1)_",1,"
+27 DO ^DIK
End DoDot:1
+28 ;
+29 SET PRCHCPD=TDATE
SET PRCHCV=VENDOR
SET (DA(1),PRCHCPO)=PDA
SET PRCHCCP=CP1
SET (PRCHCI,PRCHCII,X)=$PIECE(AA(II),"^",5)
SET DA=II
+30 IF PRCHCI'=""
DO EN3^PRCHCRD
SET ^PRC(442,PDA,2,"AE",PRCHCII,II)=""
+31 KILL PRCHCCP,PRCHCPO,PRCHCV,PRCHCI,PRCHCII
+32 QUIT
+33 ;
INCOM1 SET FLAG=0
INCOM2 if $GET(FLAG)=""
SET FLAG=1
INCOM ;
+1 KILL ^TMP($JOB)
+2 NEW ZP,LABEL,PC1,PONUM,PODATE,STAT,PANAME,ADATE,Y,XXZ,EX,P,P1,P12,P2,P23,STR,TIMEDATE
+3 if $GET(FLAG)=""
SET LABEL="INCOM"
if $GET(FLAG)=0
SET LABEL="INCOM1"
if $GET(FLAG)=1
SET LABEL="INCOM2"
+4 WRITE @IOF
+5 SET PRCF("X")="S"
DO ^PRCFSITE
if '$DATA(PRC("SITE"))
QUIT
if $GET(PRC("SITE"))="^"
QUIT
+6 WRITE !,"Please select a device for printing this report."
+7 SET %ZIS("B")=""
SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+8 IF $DATA(IO("Q"))
SET ZTSAVE("*")=""
SET ZTRTN="DETAIL^PRCH442A"
DO ^%ZTLOAD
DO ^%ZISC
KILL FLAG
QUIT
+9 DO DETAIL
DO ^%ZISC
KILL FLAG
+10 QUIT
+11 ;
DETAIL ;
+1 SET X=DT
DO NOW^%DTC
DO YX^%DTC
SET TIMEDATE=Y
SET CNT=0
+2 SET ZP=""
FOR
SET ZP=$ORDER(^PRC(442,"F",25,ZP))
if ZP=""
QUIT
Begin DoDot:1
+3 if $PIECE($GET(^PRC(442,ZP,7)),"^")=45
QUIT
+4 if $DATA(^PRC(442,ZP,11))
QUIT
+5 if $PIECE($GET(^PRC(442,ZP,12)),"^",2)'=""
QUIT
+6 SET P1=$GET(^PRC(442,ZP,0))
SET PONUM=$PIECE(P1,"^")
+7 IF $DATA(PRC("SITE"))
if $PIECE(P1,"-")'=PRC("SITE")
QUIT
+8 SET PC1=$PIECE($GET(^PRC(442,ZP,23)),"^",8)
IF PC1=""
DO DETAIL1
+9 if PC1=""
QUIT
+10 IF $GET(FLAG)=0
if $PIECE($GET(^PRC(440.5,PC1,0)),"^",8)'=DUZ
QUIT
+11 IF $GET(FLAG)=1
IF $PIECE($GET(^PRC(440.5,PC1,0)),"^",10)'=DUZ
IF $PIECE($GET(^PRC(440.5,PC1,0)),"^",9)'=DUZ
QUIT
+12 SET P2=$GET(^PRC(442,ZP,1))
SET PA=$PIECE($GET(^PRC(440.5,PC1,0)),"^",8)
if PA=""
QUIT
+13 SET PANAME=$PIECE($GET(^VA(200,PA,0)),"^")
if PANAME=""
QUIT
+14 SET Y=$PIECE(P2,"^",15)
DO DD^%DT
SET PODATE=Y
+15 SET STAT=$PIECE($GET(^PRC(442,ZP,7)),"^")
if STAT'=""
SET STAT=$PIECE($GET(^PRCD(442.3,STAT,0)),"^")
+16 SET Y=$PIECE($GET(^PRC(442,ZP,12)),"^",5)
DO DD^%DT
SET ADATE=Y
+17 SET ^TMP($JOB,ZP)=PONUM_"^"_PODATE_"^"_STAT_"^"_PANAME_"^"_ADATE
SET CNT=$GET(CNT)+1
End DoDot:1
+18 DO WRTE
+19 if $DATA(^TMP($JOB))
WRITE !!!,?10,"Total number of orders found: "_CNT
+20 KILL ^TMP($JOB),CNT
+21 QUIT
+22 ;
DETAIL1 ;Get tally for the PC user and exclude the Approving Official.
+1 if $GET(FLAG)=1
QUIT
+2 ;if the PC Coordinator is asking for the report, get the orders.
+3 IF $GET(FLAG)=""
DO DETAIL2
+4 if $PIECE($GET(^PRC(442,ZP,12)),"^",4)'=DUZ!($GET(FLAG)'=0)
QUIT
+5 SET PA=$PIECE(^PRC(442,ZP,12),"^",4)
SET PANAME=$PIECE(^VA(200,PA,0),"^")
if PANAME=""
QUIT
+6 SET Y=$PIECE(^PRC(442,ZP,12),"^",5)
DO DD^%DT
SET ADATE=Y
SET PODATE=$PIECE(Y,"@",1)
+7 SET STAT=$PIECE($GET(^PRC(442,ZP,7)),"^")
if STAT'=""
SET STAT=$PIECE($GET(^PRCD(442.3,STAT,0)),"^")
+8 SET ^TMP($JOB,ZP)=PONUM_"^"_PODATE_"^"_STAT_"^"_PANAME_"^"_ADATE
SET CNT=$GET(CNT)+1
+9 QUIT
+10 ;
DETAIL2 ;Get tally for the PC Coordinator.
+1 SET PA=$PIECE(^PRC(442,ZP,12),"^",4)
SET PANAME=$PIECE(^VA(200,PA,0),"^")
if PANAME=""
QUIT
+2 SET Y=$PIECE(^PRC(442,ZP,12),"^",5)
DO DD^%DT
SET ADATE=Y
SET PODATE=$PIECE(Y,"@",1)
+3 SET STAT=$PIECE($GET(^PRC(442,ZP,7)),"^")
if STAT'=""
SET STAT=$PIECE($GET(^PRCD(442.3,STAT,0)),"^")
+4 SET ^TMP($JOB,ZP)=PONUM_"^"_PODATE_"^"_STAT_"^"_PANAME_"^"_ADATE
SET CNT=$GET(CNT)+1
+5 QUIT
+6 ;
WRTE ;
+1 USE IO
SET (P,EX)=1
+2 IF '$DATA(^TMP($JOB))
DO HDR
WRITE !!!!,?10,"*** NO RECORDS TO PRINT ***"
QUIT
+3 SET ZP=""
FOR
SET ZP=$ORDER(^TMP($JOB,ZP))
if ZP=""
QUIT
if EX="^"
QUIT
Begin DoDot:1
+4 if P=1
DO HDR
+5 WRITE !,$PIECE(^TMP($JOB,ZP),"^"),?21,$PIECE(^TMP($JOB,ZP),"^",2),?40,$PIECE(^TMP($JOB,ZP),"^",3),!,?10,$PIECE(^TMP($JOB,ZP),"^",4),?40,$PIECE(^TMP($JOB,ZP),"^",5),!
+6 IF (IOSL-$Y)<6
DO HLD
if EX="^"
QUIT
End DoDot:1
+7 QUIT
+8 ;
C2237 ;cancel 2237 from PC order
+1 NEW I,N,T,X,ZX,PRCVIEN
+2 if '$DATA(DA)
QUIT
SET YDA=DA
SET PRCVIEN=DA
SET XDA=$PIECE($GET(^PRC(442,DA,23)),"^",23)
if XDA=""
QUIT
LOCK +^PRCS(410,XDA):15
if '$TEST
QUIT
+3 SET PRC("CP")=$PIECE($GET(^PRC(442,YDA,0)),"^",3)
if +PRC("CP")=""
QUIT
+4 SET T=$PIECE(^PRCS(410,XDA,0),"^")
SET $PIECE(^(11),"^",3)=""
SET $PIECE(^(0),"^",2)="CA"
SET $PIECE(^(5),"^")=0
SET $PIECE(^(6),"^")=0
KILL ^PRCS(410,"F",+T_"-"_+PRC("CP")_"-"_$PIECE(T,"-",5),XDA),^PRCS(410,"F1",$PIECE(T,"-",5)_"-"_+T_"-"_+PRC("CP"),XDA),^PRCS(410,"AQ",1,XDA)
+5 KILL ZX
IF $DATA(^PRCS(410,XDA,4))
SET ZX=^(4)
SET X=$PIECE(ZX,"^",8)
FOR I=1,3,6,8
SET $PIECE(ZX,"^",I)=0
+6 IF $DATA(ZX)
SET ^PRCS(410,XDA,4)=ZX
KILL ZX
+7 IF $DATA(^PRCS(410,XDA,12,0))
SET N=0
FOR I=0:0
SET N=$ORDER(^PRCS(410,XDA,12,N))
if N'>0
QUIT
SET X=$PIECE(^(N,0),"^",2)
IF X
SET DA(1)=XDA
SET DA=N
DO TRANK^PRCSEZZ
SET XDA=DA(1)
+8 DO ERS410^PRC0G(XDA_"^C")
+9 LOCK -^PRCS(410,XDA)
+10 IF $DATA(^PRC(443,XDA,0))
SET DA=XDA
SET DIK="^PRC(443,"
DO ^DIK
KILL DIK
+11 SET DA=YDA
+12 ; PRC*5.1*81 - if site runs DynaMed, may need to build update txn
+13 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1
DO DEL^PRCV442A(PRCVIEN)
+14 QUIT
+15 ;
RENUM ; delete delivery order items from repetitive item list
+1 if $GET(^PRCS(410.3,YDA,0))=""
QUIT
+2 LOCK +^PRCS(410.3,YDA):15
if '$TEST
QUIT
+3 SET IJ=""
FOR
SET IJ=$ORDER(^PRCS(410.3,YDA,1,IJ))
if IJ=""
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^PRCS(410.3,YDA,1,IJ,0)),"^",6)="O"
SET DA=IJ
SET DA(1)=YDA
SET DIK="^PRCS(410.3,"_DA(1)_",1,"
DO ^DIK
End DoDot:1
+5 LOCK -^PRCS(410.3,YDA)
+6 IF $PIECE($GET(^PRCS(410.3,YDA,1,0)),"^",4)=0
WRITE !,"This Repetitive Item List has no more items, and will be deleted."
SET DA=YDA
SET DIK="^PRCS(410.3,"
DO ^DIK
+7 KILL DIK
QUIT
+8 ;
HDR WRITE @IOF
+1 WRITE !,"INCOMPLETE PURCHASE CARD ORDERS REPORT",?45,TIMEDATE,?70,"PAGE ",P
+2 WRITE !,"PURCHASE CARD ORDER",?21,"PO DATE",?40,"SUPPLY STATUS",!,?10,"BUYER",?40,"DATE PO ASSIGNED"
+3 WRITE !
FOR I=1:1:8
WRITE "----------"
+4 SET P=P+1
+5 QUIT
+6 ;
HLD if $PIECE(IOST,"-")="P"
GOTO HDR
WRITE !,"Press return to continue, '^' to exit: "
READ XXZ:DTIME
if XXZ="^"
SET EX="^"
if '$TEST
SET EX="^"
if EX'["^"
DO HDR
QUIT
