PRCHCON2 ;WISC/KMB-CONV. TEMPORARY 2237 TO PC ORDER ;1/9/97 3:08 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
SET442 ; set variables needed to create 442 record
N NDA,SERV,IC,AA,BB,CC,CR,BOC,FSC,TOTAL,STR1,I,J,II,ZS,ZSO,PMULT,CONV,CONT,ITEM,VSTOCK,UCOST,UOP,MAX,NSN,CCEN,NCOST
N NDC,QTY,SKU,SPEC,PRCHCV,PRCHCCP,PRCHV,PRCHCPD,PRCHCI,PRCHCII,PRCHCPO
N VENDOR,VENDOR1,CNT,CNNT,CP,FCP,TDATE,SG,NDA,AR,PRCHPC
S PRCHPC=2,PRCKAREN=1
S PRC("SITE")=$P(PNW(1),"-"),PRC("FY")=$P(PNW(1),"-",2),PRC("QTR")=$P(PNW(1),"-",3),PRCSQ=1
S (CNNT,CNT,IC)=""
F I=1:1:14 S AR(I)=$G(^PRCS(410,DA,I))
S CCEN=$P(AR(3),U,3),VENDOR=$P(AR(3),U,4),VENDOR1=$P(AR(2),U),NCOST=$P(AR(4),U),CR=$P(AR(1),U,5),SG=$P(AR(11),U),FCP=PRC("CP"),CP=$P(PRC("CP")," ")
S CCEN=$P(CCEN," ")
S PRCHCV=VENDOR1,PRCHCPD=+$P(AR(1),U,15),PRCHCCP=CP
S CNNT=$P($G(^PRCS(410,DA,"IT",0)),U,4) I CNNT'="" S IC=1 F I=1:1:CNNT D
.S STR1=$G(^PRCS(410,DA,"IT",I,0)) I STR1="" Q
.S (FSC,PMULT,NSN,MAX,NDC,SKU,CONT,CONV)="",AA(IC)=$P(STR1,U) F II=2:1:7 S AA(IC)=AA(IC)_"^"_$P(STR1,"^",II)
.S UCOST=$P(STR1,U,7),ITEM=$P(STR1,U,5),QTY=$P(STR1,U,2)
.I VENDOR'="",ITEM'="",$G(^PRC(441,ITEM,2,+VENDOR,0))'="" D
..S ZSO=$G(^PRC(441,ITEM,2,+VENDOR,0)),ZS=$G(^PRC(441,ITEM,0))
..S NSN=$P(ZS,U,5),BOC=$P(ZS,U,10),FSC=$P(ZS,U,3),UCOST=$P(ZSO,U,2),CONT=$P(ZSO,U,3)
..S PMULT=$P(ZSO,U,8),MAX=$P(ZSO,U,9),CONV=$P(ZSO,U,10) S:CONT'="" CONT=$P($G(^PRC(440,+VENDOR,4,CONT,0)),U)
..S SKU=$P($G(^PRC(441,ITEM,3)),U,8)
.S CNT=+$P($G(^PRCS(410,DA,"IT",IC,1,0)),U,2) I CNT'="" S CNT=+$P($G(^PRCS(410,DA,"IT",IC,1,0)),U,4)
.I $G(CNT)'="" F J=1:1:CNT S BB(IC,J)=$G(^PRCS(410,DA,"IT",IC,1,J,0))
.S AA(IC)=AA(IC)_"^"_"^^"_UCOST_"^^^"_PMULT_"^"_NSN_"^"_MAX_"^"_NDC_"^"_SKU_"^"_CONV
.S TOTAL=QTY*UCOST,CC(IC)=TOTAL_"^"_CONT_"^"_FSC
.S IC=IC+1
S CNNT=IC-1,PRC("PARAM")=$$NODE^PRC0B("^PRC(411,PRC(""SITE""),",0)
D NOW^%DTC S SPEC=$P($G(^PRC(420,PRC("SITE"),1,CP,0)),U,12),SERV=$P($G(^(0)),U,10),TDATE=X
;;;;;;;;;;;;;;;;
S NDA=DA K DA D ^PRCHCON3
I $G(PDA)'="" S $P(^PRCS(410,NDA,4),"^",5)=$P($P(^PRC(442,PDA,0),"^"),"-",2)
K %,PDA,OUT,DR,DA,DIE,FLAG,PRC,PRCKAREN Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHCON2 2191 printed Apr 09, 2024@21:20:07 Page 2
PRCHCON2 ;WISC/KMB-CONV. TEMPORARY 2237 TO PC ORDER ;1/9/97 3:08 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
SET442 ; set variables needed to create 442 record
+1 NEW NDA,SERV,IC,AA,BB,CC,CR,BOC,FSC,TOTAL,STR1,I,J,II,ZS,ZSO,PMULT,CONV,CONT,ITEM,VSTOCK,UCOST,UOP,MAX,NSN,CCEN,NCOST
+2 NEW NDC,QTY,SKU,SPEC,PRCHCV,PRCHCCP,PRCHV,PRCHCPD,PRCHCI,PRCHCII,PRCHCPO
+3 NEW VENDOR,VENDOR1,CNT,CNNT,CP,FCP,TDATE,SG,NDA,AR,PRCHPC
+4 SET PRCHPC=2
SET PRCKAREN=1
+5 SET PRC("SITE")=$PIECE(PNW(1),"-")
SET PRC("FY")=$PIECE(PNW(1),"-",2)
SET PRC("QTR")=$PIECE(PNW(1),"-",3)
SET PRCSQ=1
+6 SET (CNNT,CNT,IC)=""
+7 FOR I=1:1:14
SET AR(I)=$GET(^PRCS(410,DA,I))
+8 SET CCEN=$PIECE(AR(3),U,3)
SET VENDOR=$PIECE(AR(3),U,4)
SET VENDOR1=$PIECE(AR(2),U)
SET NCOST=$PIECE(AR(4),U)
SET CR=$PIECE(AR(1),U,5)
SET SG=$PIECE(AR(11),U)
SET FCP=PRC("CP")
SET CP=$PIECE(PRC("CP")," ")
+9 SET CCEN=$PIECE(CCEN," ")
+10 SET PRCHCV=VENDOR1
SET PRCHCPD=+$PIECE(AR(1),U,15)
SET PRCHCCP=CP
+11 SET CNNT=$PIECE($GET(^PRCS(410,DA,"IT",0)),U,4)
IF CNNT'=""
SET IC=1
FOR I=1:1:CNNT
Begin DoDot:1
+12 SET STR1=$GET(^PRCS(410,DA,"IT",I,0))
IF STR1=""
QUIT
+13 SET (FSC,PMULT,NSN,MAX,NDC,SKU,CONT,CONV)=""
SET AA(IC)=$PIECE(STR1,U)
FOR II=2:1:7
SET AA(IC)=AA(IC)_"^"_$PIECE(STR1,"^",II)
+14 SET UCOST=$PIECE(STR1,U,7)
SET ITEM=$PIECE(STR1,U,5)
SET QTY=$PIECE(STR1,U,2)
+15 IF VENDOR'=""
IF ITEM'=""
IF $GET(^PRC(441,ITEM,2,+VENDOR,0))'=""
Begin DoDot:2
+16 SET ZSO=$GET(^PRC(441,ITEM,2,+VENDOR,0))
SET ZS=$GET(^PRC(441,ITEM,0))
+17 SET NSN=$PIECE(ZS,U,5)
SET BOC=$PIECE(ZS,U,10)
SET FSC=$PIECE(ZS,U,3)
SET UCOST=$PIECE(ZSO,U,2)
SET CONT=$PIECE(ZSO,U,3)
+18 SET PMULT=$PIECE(ZSO,U,8)
SET MAX=$PIECE(ZSO,U,9)
SET CONV=$PIECE(ZSO,U,10)
if CONT'=""
SET CONT=$PIECE($GET(^PRC(440,+VENDOR,4,CONT,0)),U)
+19 SET SKU=$PIECE($GET(^PRC(441,ITEM,3)),U,8)
End DoDot:2
+20 SET CNT=+$PIECE($GET(^PRCS(410,DA,"IT",IC,1,0)),U,2)
IF CNT'=""
SET CNT=+$PIECE($GET(^PRCS(410,DA,"IT",IC,1,0)),U,4)
+21 IF $GET(CNT)'=""
FOR J=1:1:CNT
SET BB(IC,J)=$GET(^PRCS(410,DA,"IT",IC,1,J,0))
+22 SET AA(IC)=AA(IC)_"^"_"^^"_UCOST_"^^^"_PMULT_"^"_NSN_"^"_MAX_"^"_NDC_"^"_SKU_"^"_CONV
+23 SET TOTAL=QTY*UCOST
SET CC(IC)=TOTAL_"^"_CONT_"^"_FSC
+24 SET IC=IC+1
End DoDot:1
+25 SET CNNT=IC-1
SET PRC("PARAM")=$$NODE^PRC0B("^PRC(411,PRC(""SITE""),",0)
+26 DO NOW^%DTC
SET SPEC=$PIECE($GET(^PRC(420,PRC("SITE"),1,CP,0)),U,12)
SET SERV=$PIECE($GET(^(0)),U,10)
SET TDATE=X
+27 ;;;;;;;;;;;;;;;;
+28 SET NDA=DA
KILL DA
DO ^PRCHCON3
+29 IF $GET(PDA)'=""
SET $PIECE(^PRCS(410,NDA,4),"^",5)=$PIECE($PIECE(^PRC(442,PDA,0),"^"),"-",2)
+30 KILL %,PDA,OUT,DR,DA,DIE,FLAG,PRC,PRCKAREN
QUIT
