| [613] | 1 | PRCOSS6 ;WISC/DJM/DL-SSO Server Interface to IFCAP ; 1/28/98 0900
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | Q
|
|---|
| 5 | S2 ;IF THERE ARE NO MISSING ITEMS THE SSO^PRCOSSO BACKGROUND TASK WILL FALL THROUGH INTO THIS CODE SECTION. THIS SECTION CREATS THE REPETITIVE ITEM LIST.
|
|---|
| 6 | S AA="" F S AA=$O(^PRCP(445,"AC","W",AA)) Q:AA="" S B=+^PRCP(445,AA,0),C=^PRCF(423.6,PRCDA,1,10000,0),CP=$O(^PRC(420,"AD",2,B,0)) I B=$P(C,U,3) D Q
|
|---|
| 7 | .I '$D(DT)!DT="" D NOW^%DTC S DT=X
|
|---|
| 8 | .;P182--Changed next line's CC 600000 reference to $$SUPPLYCC call
|
|---|
| 9 | .S YR=$E(DT,2,3),MO=+$E(DT,4,5),FY=$E(100+$S(+MO>9:YR+1,1:YR),2,3),QTR=$S(MO<4:2,MO<7:3,MO<10:4,1:1),M="-",X=B_M_FY_M_QTR_M_CP_M_(+$$SUPPLYCC^PRCSCK()) D EN2^PRCUTL1(.X)
|
|---|
| 10 | .K DO S DIC="^PRCS(410.3,",DIC(0)="L",DLAYGO=410.3 D FILE^DICN K DLAYGO S REC=+Y Q
|
|---|
| 11 | S E=0 F S E=$O(^PRCF(423.6,PRCDA,1,E)) Q:E'>0 S F=^(E,0),TYP=$P(F,U) I TYP="SL" D
|
|---|
| 12 | .S NSN=$P(F,U,2),NSN=$E(NSN,1,4)_M_$E(NSN,5,6)_M_$E(NSN,7,9)_M_$E(NSN,10,99),NSNB=0
|
|---|
| 13 | S2A .S NSNB=$O(^PRC(441,"BB",NSN,NSNB)),NSNC="" Q:NSNB'>0
|
|---|
| 14 | .S NSNC=^PRC(441,NSNB,0) I $P(NSNC,U,5)'=NSN G S2A
|
|---|
| 15 | .S INACT=$G(^PRC(441,NSNB,3)) G:+INACT=1 S2A
|
|---|
| 16 | .S CS=$P(F,U,5),VEN=0 F S VEN=$O(^PRC(441,NSNB,2,VEN)) G:VEN'>0 S2B S SC="" D I CS=$P(SC,U) Q
|
|---|
| 17 | ..S VEN1=^PRC(441,NSNB,2,VEN,0) Q:+VEN1'>0 S FS=$G(^PRC(440,+VEN1,2)) Q:FS="" S FS=$P(FS,U,2) Q:FS'>0 S SC=$G(^PRCD(420.8,FS,0)) Q
|
|---|
| 18 | .S QTY=+$P(F,U,4),QTYL=$L(QTY),QTY=$E(QTY,1,QTYL-2)_"."_$E(QTY,QTYL-1,99) I +$P(QTY,".",2)=0 S QTY=$P(QTY,".")
|
|---|
| 19 | .S VENDOR=$P($G(^PRC(440,+VEN1,0)),U),UC=$P(VEN1,U,2) I +$P(UC,".",2)>0 S UC=UC+.005,UC=$P(UC,".")_"."_$E($P(UC,".",2),1,2)
|
|---|
| 20 | .S TC=$P(^PRCS(410.3,REC,0),U,2)+(UC*QTY)
|
|---|
| 21 | .I $G(^PRCS(410.3,REC,1,0))="" S ^PRCS(410.3,REC,1,0)="^"_$P(^DD(410.3,1,0),U,2)
|
|---|
| 22 | .S DA(1)=REC,AQ=$O(^PRCS(410.3,DA(1),1,"B",NSNB,0))
|
|---|
| 23 | .I AQ'>0 S DIC="^PRCS(410.3,"_DA(1)_",1,",DIC(0)="L",X=NSNB,DLAYGO=410.3 K DO D FILE^DICN K DLAYGO S DA=+Y
|
|---|
| 24 | .I AQ>0 S DA=AQ,QTY=QTY+$P(^PRCS(410.3,DA(1),1,DA,0),U,2)
|
|---|
| 25 | .S DIE="^PRCS(410.3,"_DA(1)_",1,",DR="1///^S X=QTY;2////^S X=VENDOR;3///^S X=UC;4////^S X=VEN" D ^DIE S DA=DA(1) K DA(1),DO S DIE="^PRCS(410.3,",DR="2///^S X=TC" D ^DIE
|
|---|
| 26 | S2B .Q
|
|---|
| 27 | D NOW^%DTC K DO S TIME=%,DIE="^PRCS(410.3,",DR="3////^S X=AA;4///^S X=TIME;7///^S X=65",DA=REC D ^DIE S DIK="^PRCF(423.6,",DA=PRCDA D ^DIK
|
|---|
| 28 | Q
|
|---|
| 29 | SSO2 ;ENTER HERE IF THERE WERE MISSING ENTRIES IN THE WAREHOUSE
|
|---|
| 30 | ;INVENTORY FILE. SEE SSO1^PRCOSSO ENTRY POINT FOR MORE COMMENTS.
|
|---|
| 31 | N %,AA,B,C,CP,CS,DA,DIC,DIE,DIK,DR,DT,E,F,FS,FY,INACT,MO,NSN,NSNB,NSNC,QTR,QTY,QTYL,REC,SC,TC,TIME,TYP,UC,VEN,VEN1,VENDOR,X,YR G S2
|
|---|
