source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCOSS6.m@ 1005

Last change on this file since 1005 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.5 KB
Line 
1PRCOSS6 ;WISC/DJM/DL-SSO Server Interface to IFCAP ; 1/28/98 0900
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5S2 ;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
13S2A .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
26S2B .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
29SSO2 ;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
Note: See TracBrowser for help on using the repository browser.