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