- 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 Feb 18, 2025@23:31:37 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