PRCOSS6 ;WISC/DJM/DL-SSO Server Interface to IFCAP ; 1/28/98 0900
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
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.
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
.I '$D(DT)!DT="" D NOW^%DTC S DT=X
.;P182--Changed next line's CC 600000 reference to $$SUPPLYCC call
.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)
.K DO S DIC="^PRCS(410.3,",DIC(0)="L",DLAYGO=410.3 D FILE^DICN K DLAYGO S REC=+Y Q
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
.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
S2A .S NSNB=$O(^PRC(441,"BB",NSN,NSNB)),NSNC="" Q:NSNB'>0
.S NSNC=^PRC(441,NSNB,0) I $P(NSNC,U,5)'=NSN G S2A
.S INACT=$G(^PRC(441,NSNB,3)) G:+INACT=1 S2A
.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
..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
.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,".")
.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)
.S TC=$P(^PRCS(410.3,REC,0),U,2)+(UC*QTY)
.I $G(^PRCS(410.3,REC,1,0))="" S ^PRCS(410.3,REC,1,0)="^"_$P(^DD(410.3,1,0),U,2)
.S DA(1)=REC,AQ=$O(^PRCS(410.3,DA(1),1,"B",NSNB,0))
.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
.I AQ>0 S DA=AQ,QTY=QTY+$P(^PRCS(410.3,DA(1),1,DA,0),U,2)
.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
S2B .Q
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
Q
SSO2 ;ENTER HERE IF THERE WERE MISSING ENTRIES IN THE WAREHOUSE
;INVENTORY FILE. SEE SSO1^PRCOSSO ENTRY POINT FOR MORE COMMENTS.
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOSS6 2587 printed Nov 22, 2024@17:22:21 Page 2
PRCOSS6 ;WISC/DJM/DL-SSO Server Interface to IFCAP ; 1/28/98 0900
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
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.
+1 SET AA=""
FOR
SET AA=$ORDER(^PRCP(445,"AC","W",AA))
if AA=""
QUIT
SET B=+^PRCP(445,AA,0)
SET C=^PRCF(423.6,PRCDA,1,10000,0)
SET CP=$ORDER(^PRC(420,"AD",2,B,0))
IF B=$PIECE(C,U,3)
Begin DoDot:1
+2 IF '$DATA(DT)!DT=""
DO NOW^%DTC
SET DT=X
+3 ;P182--Changed next line's CC 600000 reference to $$SUPPLYCC call
+4 SET YR=$EXTRACT(DT,2,3)
SET MO=+$EXTRACT(DT,4,5)
SET FY=$EXTRACT(100+$SELECT(+MO>9:YR+1,1:YR),2,3)
SET QTR=$SELECT(MO<4:2,MO<7:3,MO<10:4,1:1)
SET M="-"
SET X=B_M_FY_M_QTR_M_CP_M_(+$$SUPPLYCC^PRCSCK())
DO EN2^PRCUTL1(.X)
+5 KILL DO
SET DIC="^PRCS(410.3,"
SET DIC(0)="L"
SET DLAYGO=410.3
DO FILE^DICN
KILL DLAYGO
SET REC=+Y
QUIT
End DoDot:1
QUIT
+6 SET E=0
FOR
SET E=$ORDER(^PRCF(423.6,PRCDA,1,E))
if E'>0
QUIT
SET F=^(E,0)
SET TYP=$PIECE(F,U)
IF TYP="SL"
Begin DoDot:1
+7 SET NSN=$PIECE(F,U,2)
SET NSN=$EXTRACT(NSN,1,4)_M_$EXTRACT(NSN,5,6)_M_$EXTRACT(NSN,7,9)_M_$EXTRACT(NSN,10,99)
SET NSNB=0
S2A SET NSNB=$ORDER(^PRC(441,"BB",NSN,NSNB))
SET NSNC=""
if NSNB'>0
QUIT
+1 SET NSNC=^PRC(441,NSNB,0)
IF $PIECE(NSNC,U,5)'=NSN
GOTO S2A
+2 SET INACT=$GET(^PRC(441,NSNB,3))
if +INACT=1
GOTO S2A
+3 SET CS=$PIECE(F,U,5)
SET VEN=0
FOR
SET VEN=$ORDER(^PRC(441,NSNB,2,VEN))
if VEN'>0
GOTO S2B
SET SC=""
Begin DoDot:2
+4 SET VEN1=^PRC(441,NSNB,2,VEN,0)
if +VEN1'>0
QUIT
SET FS=$GET(^PRC(440,+VEN1,2))
if FS=""
QUIT
SET FS=$PIECE(FS,U,2)
if FS'>0
QUIT
SET SC=$GET(^PRCD(420.8,FS,0))
QUIT
End DoDot:2
IF CS=$PIECE(SC,U)
QUIT
+5 SET QTY=+$PIECE(F,U,4)
SET QTYL=$LENGTH(QTY)
SET QTY=$EXTRACT(QTY,1,QTYL-2)_"."_$EXTRACT(QTY,QTYL-1,99)
IF +$PIECE(QTY,".",2)=0
SET QTY=$PIECE(QTY,".")
+6 SET VENDOR=$PIECE($GET(^PRC(440,+VEN1,0)),U)
SET UC=$PIECE(VEN1,U,2)
IF +$PIECE(UC,".",2)>0
SET UC=UC+.005
SET UC=$PIECE(UC,".")_"."_$EXTRACT($PIECE(UC,".",2),1,2)
+7 SET TC=$PIECE(^PRCS(410.3,REC,0),U,2)+(UC*QTY)
+8 IF $GET(^PRCS(410.3,REC,1,0))=""
SET ^PRCS(410.3,REC,1,0)="^"_$PIECE(^DD(410.3,1,0),U,2)
+9 SET DA(1)=REC
SET AQ=$ORDER(^PRCS(410.3,DA(1),1,"B",NSNB,0))
+10 IF AQ'>0
SET DIC="^PRCS(410.3,"_DA(1)_",1,"
SET DIC(0)="L"
SET X=NSNB
SET DLAYGO=410.3
KILL DO
DO FILE^DICN
KILL DLAYGO
SET DA=+Y
+11 IF AQ>0
SET DA=AQ
SET QTY=QTY+$PIECE(^PRCS(410.3,DA(1),1,DA,0),U,2)
+12 SET DIE="^PRCS(410.3,"_DA(1)_",1,"
SET DR="1///^S X=QTY;2////^S X=VENDOR;3///^S X=UC;4////^S X=VEN"
DO ^DIE
SET DA=DA(1)
KILL DA(1),DO
SET DIE="^PRCS(410.3,"
SET DR="2///^S X=TC"
DO ^DIE
S2B QUIT
End DoDot:1
+1 DO NOW^%DTC
KILL DO
SET TIME=%
SET DIE="^PRCS(410.3,"
SET DR="3////^S X=AA;4///^S X=TIME;7///^S X=65"
SET DA=REC
DO ^DIE
SET DIK="^PRCF(423.6,"
SET DA=PRCDA
DO ^DIK
+2 QUIT
SSO2 ;ENTER HERE IF THERE WERE MISSING ENTRIES IN THE WAREHOUSE
+1 ;INVENTORY FILE. SEE SSO1^PRCOSSO ENTRY POINT FOR MORE COMMENTS.
+2 NEW %,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
GOTO S2
